diff --git a/data_override/include/data_override.inc b/data_override/include/data_override.inc index 91d7ea8157..305e58ae6c 100644 --- a/data_override/include/data_override.inc +++ b/data_override/include/data_override.inc @@ -618,13 +618,13 @@ end subroutine get_domainUG !=============================================================================================== !> @brief Routine to perform data override for scalar fields -subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_index) +subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data_out,time,override,data_index) character(len=3), intent(in) :: gridname !< model grid ID (ocn,ice,atm,lnd) character(len=*), intent(in) :: fieldname_code !< field name as used in the model (may be !! different from the name in NetCDF data file) logical, intent(out), optional :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time - real(FMS_DATA_OVERRIDE_KIND_), intent(out) :: data !< output data array returned by this call + real(FMS_DATA_OVERRIDE_KIND_), intent(out) :: data_out !< output data array returned by this call integer, intent(in), optional :: data_index character(len=512) :: filename !< file containing source data @@ -661,7 +661,7 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind factor = data_table(index1)%factor if(fieldname == "") then - data = factor + data_out = factor if(PRESENT(override)) override = .true. return else @@ -696,8 +696,8 @@ subroutine DATA_OVERRIDE_0D_(gridname,fieldname_code,data,time,override,data_ind endif !if curr_position < 0 !10 do time interp to get data in compute_domain - call time_interp_external(id_time, time, data, verbose=.false.) - data = data*factor + call time_interp_external(id_time, time, data_out, verbose=.false.) + data_out = data_out*factor !$OMP END SINGLE if(PRESENT(override)) override = .true. @@ -737,13 +737,13 @@ subroutine DATA_OVERRIDE_2D_(gridname,fieldname,data_2D,time,override, is_in, ie end subroutine DATA_OVERRIDE_2D_ !> @brief This routine performs data override for 3D fields -subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_index, is_in, ie_in, js_in, je_in) +subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,return_data,time,override,data_index, is_in, ie_in, js_in, je_in) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname_code !< field name as used in the model logical, optional, intent(out) :: override !< true if the field has been overriden succesfully type(time_type), intent(in) :: time !< (target) model time integer, optional, intent(in) :: data_index - real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:,:), intent(inout) :: return_data !< data returned by this call integer, optional, intent(in) :: is_in, ie_in, js_in, je_in logical, dimension(:,:,:), allocatable :: mask_out @@ -810,7 +810,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind factor = data_table(index1)%factor if(fieldname == "") then - data = factor + return_data = factor if(PRESENT(override)) override = .true. return else @@ -852,23 +852,25 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind override_array(curr_position)%numthreads = omp_get_num_threads() #endif !--- data_override may be called from physics windows. The following are possible situations -!--- 1. size(data,1) == nxd and size(data,2) == nyd ( on data domain and there is only one window). -!--- 2. nxc is divisible by size(data,1), nyc is divisible by size(data,2), -!--- nwindow = (nxc/size(data(1))*(nyc/size(data,2)), also we require nwindows is divisible by nthreads. -!--- The another restrition is that size(data,1) == ie_in - is_in + 1, -!--- size(data,2) == je_in - js_in + 1 +!--- 1. size(return_data,1) == nxd and size(return_data,2) == nyd +!--- (on return_data domain and there is only one window). +!--- 2. nxc is divisible by size(return_data,1), nyc is divisible by size(return_data,2), +!--- nwindow = (nxc/size(return_data(1))*(nyc/size(return_data,2)), +!--- also we require nwindows is divisible by nthreads. +!--- The another restrition is that size(return_data,1) == ie_in - is_in + 1, +!--- size(return_data,2) == je_in - js_in + 1 nwindows = 1 - if( nxd == size(data,1) .AND. nyd == size(data,2) ) then ! + if( nxd == size(return_data,1) .AND. nyd == size(return_data,2) ) then ! use_comp_domain = .false. - else if ( mod(nxc, size(data,1)) ==0 .AND. mod(nyc, size(data,2)) ==0 ) then + else if ( mod(nxc, size(return_data,1)) ==0 .AND. mod(nyc, size(return_data,2)) ==0 ) then use_comp_domain = .true. - nwindows = (nxc/size(data,1))*(nyc/size(data,2)) + nwindows = (nxc/size(return_data,1))*(nyc/size(return_data,2)) else call mpp_error(FATAL, & & "data_override: data is not on data domain and compute domain is not divisible by size(data)") endif - override_array(curr_position)%window_size(1) = size(data,1) - override_array(curr_position)%window_size(2) = size(data,2) + override_array(curr_position)%window_size(1) = size(return_data,1) + override_array(curr_position)%window_size(2) = size(return_data,2) window_size = override_array(curr_position)%window_size override_array(curr_position)%numwindows = nwindows @@ -1014,7 +1016,7 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind je_src = override_array(curr_position)%je_src window_size = override_array(curr_position)%window_size !---make sure data size match window_size - if( window_size(1) .NE. size(data,1) .OR. window_size(2) .NE. size(data,2) ) then + if( window_size(1) .NE. size(return_data,1) .OR. window_size(2) .NE. size(return_data,2) ) then call mpp_error(FATAL, "data_override: window_size does not match size(data)") endif !9 Get id_time previously stored in override_array @@ -1086,92 +1088,92 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind ! Determine if data in netCDF file is 2D or not data_file_is_2D = .false. - if((dims(3) == 1) .and. (size(data,3)>1)) data_file_is_2D = .true. + if((dims(3) == 1) .and. (size(return_data,3)>1)) data_file_is_2D = .true. - if(dims(3) .NE. 1 .and. (size(data,3) .NE. dims(3))) & - call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(data,3) .NE. dims(3)") + if(dims(3) .NE. 1 .and. (size(return_data,3) .NE. dims(3))) & + call mpp_error(FATAL, "data_override: dims(3) .NE. 1 and size(return_data,3) .NE. dims(3)") if(ongrid) then if (.not. use_comp_domain) then !< Determine the size of the halox and the part of `data` that is in the compute domain - nhalox = (size(data,1) - nxc)/2 - nhaloy = (size(data,2) - nyc)/2 - startingi = lbound(data,1) + nhalox - startingj = lbound(data,2) + nhaloy - endingi = ubound(data,1) - nhalox - endingj = ubound(data,2) - nhaloy + nhalox = (size(return_data,1) - nxc)/2 + nhaloy = (size(return_data,2) - nyc)/2 + startingi = lbound(return_data,1) + nhalox + startingj = lbound(return_data,2) + nhaloy + endingi = ubound(return_data,1) - nhalox + endingj = ubound(return_data,2) - nhaloy end if !10 do time interp to get data in compute_domain if(data_file_is_2D) then if (use_comp_domain) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) else !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(startingi:endingi,startingj:endingj,1),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) end if - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) + return_data(:,:,1) = return_data(:,:,1)*factor + do i = 2, size(return_data,3) + return_data(:,:,i) = return_data(:,:,1) end do else if (use_comp_domain) then - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) else !> If this in an ongrid case and you are not in the compute domain, send in `data` to be the correct !! size - call time_interp_external(id_time,time,data(startingi:endingi,startingj:endingj,:),verbose=.false., & + call time_interp_external(id_time,time,return_data(startingi:endingi,startingj:endingj,:),verbose=.false., & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) end if - data = data*factor + return_data = return_data*factor endif else ! off grid case ! do time interp to get global data if(data_file_is_2D) then if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data(:,:,1) = data(:,:,1)*factor - do i = 2, size(data,3) - data(:,:,i) = data(:,:,1) + return_data(:,:,1) = return_data(:,:,1)*factor + do i = 2, size(return_data,3) + return_data(:,:,i) = return_data(:,:,1) enddo else - allocate(mask_out(size(data,1), size(data,2),1)) + allocate(mask_out(size(return_data,1), size(return_data,2),1)) mask_out = .false. - call time_interp_external(id_time,time,data(:,:,1),verbose=.false., & + call time_interp_external(id_time,time,return_data(:,:,1),verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & mask_out =mask_out(:,:,1), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) where(mask_out(:,:,1)) - data(:,:,1) = data(:,:,1)*factor + return_data(:,:,1) = return_data(:,:,1)*factor end where - do i = 2, size(data,3) + do i = 2, size(return_data,3) where(mask_out(:,:,1)) - data(:,:,i) = data(:,:,1) + return_data(:,:,i) = return_data(:,:,1) end where enddo deallocate(mask_out) endif else if( data_table(index1)%region_type == NO_REGION ) then - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) - data = data*factor + return_data = return_data*factor else - allocate(mask_out(size(data,1), size(data,2), size(data,3)) ) + allocate(mask_out(size(return_data,1), size(return_data,2), size(return_data,3)) ) mask_out = .false. - call time_interp_external(id_time,time,data,verbose=.false., & + call time_interp_external(id_time,time,return_data,verbose=.false., & horz_interp=override_array(curr_position)%horz_interp(window_id), & mask_out =mask_out, & is_in=is_in,ie_in=ie_in,js_in=js_in,je_in=je_in,window_id=window_id) where(mask_out) - data = data*factor + return_data = return_data*factor end where deallocate(mask_out) endif @@ -1183,10 +1185,10 @@ subroutine DATA_OVERRIDE_3D_(gridname,fieldname_code,data,time,override,data_ind end subroutine DATA_OVERRIDE_3D_ !> @brief Data override for 1D unstructured grids -subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,return_data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(FMS_DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:), intent(inout) :: return_data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars @@ -1212,16 +1214,16 @@ subroutine DATA_OVERRIDE_UG_1D_(gridname,fieldname,data,time,override) call DATA_OVERRIDE_2D_(gridname,fieldname,data_SG,time,override) - call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), data(:)) + call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:), return_data(:)) deallocate(data_SG) end subroutine DATA_OVERRIDE_UG_1D_ !> @brief Data override for 2D unstructured grids -subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) +subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,return_data,time,override) character(len=3), intent(in) :: gridname !< model grid ID character(len=*), intent(in) :: fieldname !< field to override - real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: data !< data returned by this call + real(FMS_DATA_OVERRIDE_KIND_), dimension(:,:), intent(inout) :: return_data !< data returned by this call type(time_type), intent(in) :: time !< model time logical, intent(out), optional :: override !< true if the field has been overriden succesfully !local vars @@ -1243,18 +1245,18 @@ subroutine DATA_OVERRIDE_UG_2D_(gridname,fieldname,data,time,override) enddo if(index1 .eq. -1) return ! NO override was performed - nlevel = size(data,2) + nlevel = size(return_data,2) nlevel_max = nlevel call mpp_max(nlevel_max) call get_domainUG(gridname,UG_domain,comp_domain) allocate(data_SG(comp_domain(1):comp_domain(2),comp_domain(3):comp_domain(4),nlevel_max)) - allocate(data_UG(size(data,1), nlevel_max)) + allocate(data_UG(size(return_data,1), nlevel_max)) data_SG = 0._lkind call DATA_OVERRIDE_3D_(gridname,fieldname,data_SG,time,override) call mpp_pass_SG_to_UG(UG_domain, data_SG(:,:,:), data_UG(:,:)) - data(:,1:nlevel) = data_UG(:,1:nlevel) + return_data(:,1:nlevel) = data_UG(:,1:nlevel) deallocate(data_SG, data_UG) end subroutine DATA_OVERRIDE_UG_2D_ diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90 index 45deb4c446..ed898a52d3 100644 --- a/diag_integral/diag_integral.F90 +++ b/diag_integral/diag_integral.F90 @@ -1043,30 +1043,30 @@ end function diag_integral_alarm !! Template: !! !! @code{.f90} -!! data2 = vert_diag_integral (data, wt) +!! data2 = vert_diag_integral (field_data, wt) !! @endcode !! !! Parameters: !! !! @code{.f90} -!! real, dimension (:,:,:), intent(in) :: data, wt -!! real, dimension (size(data,1),size(data,2)) :: data2 +!! real, dimension (:,:,:), intent(in) :: field_data, wt +!! real, dimension (size(field_data,1),size(field_data,2)) :: data2 !! @endcode !! -!! @param [in] integral field data arrays +!! @param [in] integral field data arrays !! @param [in] integral field weighting functions !! @param [out] !! @return real array data2 -function vert_diag_integral (data, wt) result (data2) -real(r8_kind), dimension (:,:,:), intent(in) :: data !< integral field data arrays +function vert_diag_integral (field_data, wt) result (data2) +real(r8_kind), dimension (:,:,:), intent(in) :: field_data !< integral field data arrays real(r8_kind), dimension (:,:,:), intent(in) :: wt !< integral field weighting functions -real(r8_kind), dimension (size(data,1),size(data,2)) :: data2 +real(r8_kind), dimension (size(field_data,1),size(field_data,2)) :: data2 !------------------------------------------------------------------------------- ! local variables: ! wt2 !------------------------------------------------------------------------------- - real, dimension(size(data,1),size(data,2)) :: wt2 + real, dimension(size(field_data,1),size(field_data,2)) :: wt2 !------------------------------------------------------------------------------- wt2 = sum(wt,3) @@ -1074,7 +1074,7 @@ function vert_diag_integral (data, wt) result (data2) call error_mesg ('diag_integral_mod', & 'vert sum of weights equals zero', FATAL) endif - data2 = sum(data*wt,3) / wt2 + data2 = sum(field_data*wt,3) / wt2 end function vert_diag_integral diff --git a/diag_integral/include/diag_integral.inc b/diag_integral/include/diag_integral.inc index a407b49796..200819c171 100644 --- a/diag_integral/include/diag_integral.inc +++ b/diag_integral/include/diag_integral.inc @@ -31,25 +31,25 @@ !! Template: !! !! @code{.f90} -!! call sum_field_2d (name, data, is, js) +!! call sum_field_2d (name, field_data2d, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:) +!! real, intent(in) :: field_data2d(:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_2D_ (name, data, is, js) +subroutine SUM_FIELD_2D_ (name, field_data2d, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data2d(:,:) !< field of integrands to be summed over integer, optional, intent(in) :: is !< starting i indices over which summation is to occur integer, optional, intent(in) :: js !< starting j indices over which summation is to occur @@ -90,8 +90,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation i !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data2d,1) - 1 + j2 = j1 + size(field_data2d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral and add the @@ -99,9 +99,9 @@ integer, optional, intent(in) :: js !< starting j indices over which summation i !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count(field) + & - size(data,1)*size(data,2) + size(field_data2d,1)*size(field_data2d,2) field_sum (field) = field_sum (field) + & - sum (real(data,r8_kind) * area(i1:i2,j1:j2)) + sum (real(field_data2d,r8_kind) * area(i1:i2,j1:j2)) !$OMP END CRITICAL @@ -117,25 +117,25 @@ end subroutine SUM_FIELD_2D_ !! Template: !! !! @code{.f90} -!! call sum_field_3d (name, data, is, js) +!! call sum_field_3d (name, field_data3d, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:,:) +!! real, intent(in) :: field_data3d(:,:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_3D_ (name, data, is, js) +subroutine SUM_FIELD_3D_ (name, field_data3d, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data3d(:,:,:) !< field of integrands to be summed over integer, optional, intent(in) :: is !< starting i,j indices over which summation is to occur integer, optional, intent(in) :: js !< starting i,j indices over which summation is to occur @@ -146,8 +146,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation ! i1, j1, i2, j2 ! location indices of current data in ! processor-global coordinates !------------------------------------------------------------------------------- - real(r8_kind), dimension (size(data,1), & - size(data,2)) :: data2 + real(r8_kind), dimension (size(field_data3d,1), & + size(field_data3d,2)) :: data2 integer :: field !< index of desired integral integer :: i1 !< location indices of current data in @@ -183,8 +183,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data3d,1) - 1 + j2 = j1 + size(field_data3d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral. sum first @@ -193,8 +193,8 @@ integer, optional, intent(in) :: js !< starting i,j indices over which summation !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count (field) + & - size(data,1)*size(data,2) - data2 = sum(real(data,r8_kind),3) + size(field_data3d,1)*size(field_data3d,2) + data2 = sum(real(field_data3d,r8_kind),3) field_sum (field) = field_sum (field) + & sum (data2 * area(i1:i2,j1:j2)) @@ -212,26 +212,26 @@ end subroutine SUM_FIELD_3D_ !! Template: !! !! @code{.f90} -!! call sum_field_wght_3d (name, data, wt, is, js) +!! call sum_field_wght_3d (name, field_data3d, wt, is, js) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:,:), wt(:,:,:) +!! real, intent(in) :: field_data3d(:,:,:), wt(:,:,:) !! integer, optional, intent(in) :: is, js !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] the weight function to be evaluated at summation !! @param [in] starting i,j indices over which summation is to occur !! -subroutine SUM_FIELD_WGHT_3D_ (name, data, wt, is, js) +subroutine SUM_FIELD_WGHT_3D_ (name, field_data3d, wt, is, js) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_), intent(in) :: data(:,:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_), intent(in) :: field_data3d(:,:,:) !< field of integrands to be summed over real(FMS_DI_KIND_), intent(in) :: wt(:,:,:) !< the weight function to be evaluated at summation integer, optional, intent(in) :: is !< starting i indices over which summation is to occur integer, optional, intent(in) :: js !< starting j indices over which summation is to occur @@ -243,7 +243,7 @@ integer, optional, intent(in) :: js !< starting j indices over which summation ! i1, j1, i2, j2 ! location indices of current data in ! processor-global coordinates !------------------------------------------------------------------------------- - real(r8_kind), dimension (size(data,1),size(data,2)) :: data2 + real(r8_kind), dimension (size(field_data3d,1),size(field_data3d,2)) :: data2 integer :: field !< index of desired integral integer :: i1 !< location indices of current data in !! processor-global coordinates @@ -277,8 +277,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation !------------------------------------------------------------------------------- i1 = 1; if (present(is)) i1 = is j1 = 1; if (present(js)) j1 = js - i2 = i1 + size(data,1) - 1 - j2 = j1 + size(data,2) - 1 + i2 = i1 + size(field_data3d,1) - 1 + j2 = j1 + size(field_data3d,2) - 1 !------------------------------------------------------------------------------- ! increment the count of points toward this integral. sum first @@ -288,8 +288,8 @@ integer, optional, intent(in) :: js !< starting j indices over which summation !------------------------------------------------------------------------------- !$OMP CRITICAL field_count (field) = field_count (field) + & - size(data,1)*size(data,2) - data2 = vert_diag_integral (real(data,r8_kind), real(wt,r8_kind)) + size(field_data3d,1)*size(field_data3d,2) + data2 = vert_diag_integral (real(field_data3d,r8_kind), real(wt,r8_kind)) field_sum(field) = field_sum (field) + & sum (data2 * area(i1:i2,j1:j2)) @@ -307,26 +307,26 @@ end subroutine SUM_FIELD_WGHT_3D_ !! Template: !! !! @code{.f90} -!! call sum_field_2d_hemi (name, data, is, ie, js, je) +!! call sum_field_2d_hemi (name, field_data2d, is, ie, js, je) !! @endcode !! !! Parameters: !! !! @code{.f90} !! character(len=*), intent(in) :: name -!! real, intent(in) :: data(:,:) +!! real, intent(in) :: field_data2d(:,:) !! integer, intent(in) :: is, js, ie, je !! @endcode !! !! @param [in] Name of the field to be integrated -!! @param [in] field of integrands to be summed over +!! @param [in] field of integrands to be summed over !! @param [in] starting/ending i,j indices over which summation !! is to occur !! -subroutine SUM_FIELD_2D_HEMI_ (name, data, is, ie, js, je) +subroutine SUM_FIELD_2D_HEMI_ (name, field_data2d, is, ie, js, je) character(len=*), intent(in) :: name !< Name of the field to be integrated -real(FMS_DI_KIND_),intent(in) :: data(:,:) !< field of integrands to be summed over +real(FMS_DI_KIND_),intent(in) :: field_data2d(:,:) !< field of integrands to be summed over integer, intent(in) :: is !< starting/ending i,j indices over which summation !! is to occur integer, intent(in) :: js !< starting/ending i,j indices over which summation @@ -374,14 +374,14 @@ integer, intent(in) :: je !< starting/ending i,j indices over which su ! is needed to handle case of 2d domain decomposition with physics ! window smaller than processor domain size. !------------------------------------------------------------------------------- - i1 = mod ( (is-1), size(data,1) ) + 1 - i2 = i1 + size(data,1) - 1 + i1 = mod ( (is-1), size(field_data2d,1) ) + 1 + i2 = i1 + size(field_data2d,1) - 1 !------------------------------------------------------------------------------- ! for a hemispheric sum, sum one jrow at a time in case a processor ! has data from both hemispheres. !------------------------------------------------------------------------------- - j1 = mod ( (js-1) ,size(data,2) ) + 1 + j1 = mod ( (js-1) ,size(field_data2d,2) ) + 1 j2 = j1 !------------------------------------------------------------------------------- @@ -392,7 +392,7 @@ integer, intent(in) :: je !< starting/ending i,j indices over which su !$OMP CRITICAL field_count (field) = field_count (field) + 2* (i2-i1+1)*(j2-j1+1) field_sum (field) = field_sum (field) + & - sum ( real(data(i1:i2,j1:j2),r8_kind) * area(is:ie,js:je)) + sum ( real(field_data2d(i1:i2,j1:j2),r8_kind) * area(is:ie,js:je)) !$OMP END CRITICAL diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 7eb5eaf686..606ebd76f2 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -105,10 +105,10 @@ MODULE diag_axis_mod !! increments the axis counter and fills in the axes !! !! @return integer axis ID - INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,& + INTEGER FUNCTION diag_axis_init(name, array_data, units, cart_name, long_name, direction,& & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) CHARACTER(len=*), INTENT(in) :: name !< Short name for axis - CLASS(*), DIMENSION(:), INTENT(in) :: DATA !< Array of coordinate values + CLASS(*), DIMENSION(:), INTENT(in) :: array_data !< Array of coordinate values CHARACTER(len=*), INTENT(in) :: units !< Units for the axis CHARACTER(len=*), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T") CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. @@ -220,17 +220,17 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi IF ( Axes(diag_axis_init)%cart_name == 'T' ) THEN axlen = 0 ELSE - axlen = SIZE(DATA(:)) + axlen = SIZE(array_data(:)) END IF - ALLOCATE ( Axes(diag_axis_init)%data(1:axlen) ) + ALLOCATE ( Axes(diag_axis_init)%diag_type_data(1:axlen) ) ! Initialize Axes(diag_axis_init) Axes(diag_axis_init)%name = TRIM(name) - SELECT TYPE (DATA) + SELECT TYPE (array_data) TYPE IS (real(kind=r4_kind)) - Axes(diag_axis_init)%data = DATA(1:axlen) + Axes(diag_axis_init)%diag_type_data = array_data(1:axlen) TYPE IS (real(kind=r8_kind)) - Axes(diag_axis_init)%data = real(DATA(1:axlen)) + Axes(diag_axis_init)%diag_type_data = real(array_data(1:axlen)) CLASS DEFAULT CALL error_mesg('diag_axis_mod::diag_axis_init',& & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -455,7 +455,7 @@ INTEGER FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2 END FUNCTION diag_subaxes_init !> @brief Return information about the axis with index ID SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& - & direction, edges, Domain, DomainU, DATA, num_attributes, attributes, domain_position) + & direction, edges, Domain, DomainU, array_data, num_attributes, attributes, domain_position) CHARACTER(len=*), INTENT(out) :: name, units, long_name, cart_name INTEGER, INTENT(in) :: id !< Axis ID TYPE(domain1d), INTENT(out) :: Domain @@ -463,7 +463,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& INTEGER, INTENT(out) :: direction !< Direction of data. (See @ref diag_axis_init for a description of !! allowed values) INTEGER, INTENT(out) :: edges !< Axis ID for the previously defined "edges axis". - CLASS(*), DIMENSION(:), INTENT(out) :: DATA !< Array of coordinate values for this axis. + CLASS(*), DIMENSION(:), INTENT(out) :: array_data !< Array of coordinate values for this axis. INTEGER, INTENT(out), OPTIONAL :: num_attributes TYPE(diag_atttype), ALLOCATABLE, DIMENSION(:), INTENT(out), OPTIONAL :: attributes INTEGER, INTENT(out), OPTIONAL :: domain_position @@ -480,15 +480,15 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& Domain = Axes(id)%Domain DomainU = Axes(id)%DomainUG if (present(domain_position)) domain_position = Axes(id)%domain_position - IF ( Axes(id)%length > SIZE(DATA(:)) ) THEN + IF ( Axes(id)%length > SIZE(array_data(:)) ) THEN ! array data is too small. CALL error_mesg('diag_axis_mod::get_diag_axis', 'array data is too small', FATAL) ELSE - SELECT TYPE (DATA) + SELECT TYPE (array_data) TYPE IS (real(kind=r4_kind)) - DATA(1:Axes(id)%length) = real(Axes(id)%data(1:Axes(id)%length), kind=r4_kind) + array_data(1:Axes(id)%length) = real(Axes(id)%diag_type_data(1:Axes(id)%length), kind=r4_kind) TYPE IS (real(kind=r8_kind)) - DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) + array_data(1:Axes(id)%length) = Axes(id)%diag_type_data(1:Axes(id)%length) CLASS DEFAULT CALL error_mesg('diag_axis_mod::get_diag_axis',& & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -562,16 +562,16 @@ SUBROUTINE get_diag_axis_cart(id, cart_name) END SUBROUTINE get_diag_axis_cart !> @brief Return the axis data. - SUBROUTINE get_diag_axis_data(id, DATA) + SUBROUTINE get_diag_axis_data(id, axis_data) INTEGER, INTENT(in) :: id !< Axis ID - REAL, DIMENSION(:), INTENT(out) :: DATA !< Axis data + REAL, DIMENSION(:), INTENT(out) :: axis_data !< Axis data CALL valid_id_check(id, 'get_diag_axis_data') - IF (Axes(id)%length > SIZE(DATA(:))) THEN + IF (Axes(id)%length > SIZE(axis_data(:))) THEN ! array data is too small CALL error_mesg('diag_axis_mod::get_diag_axis_data', 'array data is too small', FATAL) ELSE - DATA(1:Axes(id)%length) = Axes(id)%data + axis_data(1:Axes(id)%length) = Axes(id)%diag_type_data END IF END SUBROUTINE get_diag_axis_data diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 1f443ce220..e5d7942946 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -258,7 +258,7 @@ MODULE diag_data_mod CHARACTER(len=128) :: name CHARACTER(len=256) :: units, long_name CHARACTER(len=1) :: cart_name - REAL, DIMENSION(:), POINTER :: data + REAL, DIMENSION(:), POINTER :: diag_type_data INTEGER, DIMENSION(MAX_SUBAXES) :: start INTEGER, DIMENSION(MAX_SUBAXES) :: end CHARACTER(len=128), DIMENSION(MAX_SUBAXES) :: subaxis_name diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 9a2506f5be..9a72598915 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -4005,7 +4005,7 @@ END FUNCTION need_data INTEGER FUNCTION init_diurnal_axis(n_samples) INTEGER, INTENT(in) :: n_samples !< number of intervals during the day - REAL :: DATA (n_samples) !< central points of time intervals + REAL :: center_data (n_samples) !< central points of time intervals REAL :: edges (n_samples+1) !< boundaries of time intervals INTEGER :: edges_id !< id of the corresponding edges INTEGER :: i @@ -4024,7 +4024,7 @@ INTEGER FUNCTION init_diurnal_axis(n_samples) ! compute central points and units edges(1) = 0.0 DO i = 1, n_samples - DATA (i) = 24.0*(REAL(i)-0.5)/n_samples + center_data (i) = 24.0*(REAL(i)-0.5)/n_samples edges(i+1) = 24.0* REAL(i)/n_samples END DO @@ -4041,7 +4041,8 @@ INTEGER FUNCTION init_diurnal_axis(n_samples) WRITE (name,'(a,i2.2)') 'time_of_day_', n_samples init_diurnal_axis = get_axis_num(name, 'diurnal') IF ( init_diurnal_axis <= 0 ) THEN - init_diurnal_axis = diag_axis_init(name, DATA, units, 'N', 'time of day', set_name='diurnal', edges=edges_id) + init_diurnal_axis = diag_axis_init(name, center_data, units, 'N', 'time of day', & + set_name='diurnal', edges=edges_id) END IF END FUNCTION init_diurnal_axis diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 25ffeb9cc4..5591c293a3 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -1706,7 +1706,7 @@ SUBROUTINE opening_file(file, time, filename_time) !! writting periodic files TYPE(time_type) :: fname_time !< Time used in setting the filename when writting periodic files - REAL, DIMENSION(2) :: DATA + REAL, DIMENSION(2) :: open_file_data INTEGER :: j, field_num, input_field_num, num_axes, k INTEGER :: field_num1 INTEGER :: position @@ -2084,9 +2084,9 @@ SUBROUTINE opening_file(file, time, filename_time) time_axis_id(1) = files(file)%time_axis_id time_bounds_id(1) = files(file)%time_bounds_id CALL get_diag_axis( time_axis_id(1), time_name, time_units, time_longname,& - & cart_name, dir, edges, Domain, domainU, DATA) + & cart_name, dir, edges, Domain, domainU, open_file_data) CALL get_diag_axis( time_bounds_id(1), timeb_name, timeb_units, timeb_longname,& - & cart_name, dir, edges, Domain, domainU, DATA) + & cart_name, dir, edges, Domain, domainU, open_file_data) ! CF Compliance requires the unit on the _bnds axis is the same as 'time' files(file)%f_bounds = write_field_meta_data(files(file)%file_unit,& & TRIM(time_name)//'_bnds', (/time_bounds_id,time_axis_id/),& diff --git a/drifters/drifters_comm.F90 b/drifters/drifters_comm.F90 index e94e2a7f23..b5a40e82e3 100644 --- a/drifters/drifters_comm.F90 +++ b/drifters/drifters_comm.F90 @@ -641,7 +641,7 @@ subroutine drifters_comm_gather(self, drfts, dinp, & integer, allocatable :: nps(:) real :: x, y real, allocatable :: lons0(:), lats0(:), recvbuf(:,:) - real :: data(drfts%nd+3, drfts%np) + real :: com_data(drfts%nd+3, drfts%np) !communication data comm = MPI_COMM_WORLD if(present(mycomm)) comm = mycomm @@ -668,10 +668,10 @@ subroutine drifters_comm_gather(self, drfts, dinp, & if( x <= self%xcmax .and. x >= self%xcmin .and. & & y <= self%ycmax .and. y >= self%ycmin) then npf = npf + 1 - data(1 , npf) = real(drfts%ids(ip)) - data(1+1:1+nd, npf) = drfts%positions(:, ip) - data( 2+nd, npf) = lons(ip) - data( 3+nd, npf) = lats(ip) + com_data(1 , npf) = real(drfts%ids(ip)) + com_data(1+1:1+nd, npf) = drfts%positions(:, ip) + com_data( 2+nd, npf) = lons(ip) + com_data( 3+nd, npf) = lats(ip) endif enddo @@ -700,12 +700,12 @@ subroutine drifters_comm_gather(self, drfts, dinp, & ! Each PE sends data to recvbuf on root_pe. #ifdef _USE_MPI - call mpi_gather( data , npf*(nd+3), MPI_REAL8, & + call mpi_gather( com_data , npf*(nd+3), MPI_REAL8, & & recvbuf, npmax*(nd+3), MPI_REAL8, & & root_pe, comm, ier) !!if(ier/=0) ermesg = 'drifters_write_restart: ERROR while gathering "data"' #else - if(npf > 0) call mpp_send(data(1,1), plen=npf*(nd+3), to_pe=root_pe, tag=COMM_TAG_4) + if(npf > 0) call mpp_send(com_data(1,1), plen=npf*(nd+3), to_pe=root_pe, tag=COMM_TAG_4) if(pe==root_pe) then do i = self%pe_beg, self%pe_end if(nps(i) > 0) call mpp_recv(recvbuf(1, i), glen=nps(i)*(nd+3), from_pe=i, tag=COMM_TAG_4) diff --git a/drifters/drifters_set_field.fh b/drifters/drifters_set_field.fh index 9ca2a2acf5..dd60b20f3b 100644 --- a/drifters/drifters_set_field.fh +++ b/drifters/drifters_set_field.fh @@ -22,7 +22,7 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & #if _DIMS >= 3 & z, & #endif - & data, ermesg) + & set_field_data, ermesg) use cloud_interpolator_mod type(drifters_type) :: self ! field index must be consistent with field_names from input file @@ -30,11 +30,11 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & real, intent(in) :: x(:) real, intent(in) :: y(:) #if _DIMS == 2 - real, intent(in) :: data(:,:) + real, intent(in) :: set_field_data(:,:) #endif #if _DIMS == 3 real, intent(in) :: z(:) - real, intent(in) :: data(:,:,:) + real, intent(in) :: set_field_data(:,:,:) #endif character(len=*), intent(out) :: ermesg @@ -52,12 +52,12 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & nsizes(3) = size(z) #endif - if(nsizes(1) /= size(data, 1) .or. nsizes(2) /= size(data, 2)) then + if(nsizes(1) /= size(set_field_data, 1) .or. nsizes(2) /= size(set_field_data, 2)) then ermesg = 'drifters_set_field_XXX: ERROR size mismatch between data and x or y' return end if #if _DIMS >=3 - if(nsizes(3) /= size(data, 3)) then + if(nsizes(3) /= size(set_field_data, 3)) then ermesg = 'drifters_set_field_XXX: ERROR size mismatch between data and z' return endif @@ -104,7 +104,7 @@ subroutine drifters_set_field_XXX(self, index_field, x, y, & ts(3) = (self%core%positions(3,ip) - z(j))/(z(j+1) - z(j)) #endif - call cld_ntrp_get_cell_values(nsizes, _FLATTEN(data), ij, fvals, ier) + call cld_ntrp_get_cell_values(nsizes, _FLATTEN(set_field_data), ij, fvals, ier) call cld_ntrp_linear_cell_interp(fvals, ts, self%fields(index_field, ip), ier) enddo diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index 198dd17288..3cf69cfab4 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -1457,18 +1457,18 @@ end subroutine get_grid_version2 !####################################################################### !> @brief Read the area elements from NetCDF file -subroutine get_area_elements_fms2_io(fileobj, name, data) +subroutine get_area_elements_fms2_io(fileobj, name, get_area_data) type(FmsNetcdfDomainFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(r8_kind), intent(out) :: data(:,:) + real(r8_kind), intent(out) :: get_area_data(:,:) if(variable_exists(fileobj, name)) then - call read_data(fileobj, name, data) + call read_data(fileobj, name, get_area_data) else call error_mesg('xgrid_mod', 'no field named '//trim(name)//' in grid file '//trim(fileobj%path)// & ' Will set data to negative values...', NOTE) ! area elements no present in grid_spec file, set to negative values.... - data = -1.0_r8_kind + get_area_data = -1.0_r8_kind endif end subroutine get_area_elements_fms2_io @@ -4418,7 +4418,7 @@ end subroutine get_index_range !! first grid, which typically is on the atmos side. !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_3d(from, to, grid_index, data, xmap, & +subroutine stock_move_3d(from, to, grid_index, stock_data3d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 3 data, it can be used to compute the flux on anything but the @@ -4431,7 +4431,7 @@ subroutine stock_move_3d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, intent(in) :: grid_index !< grid index - real(r8_kind), intent(in) :: data(:,:,:) !< data array is 3d + real(r8_kind), intent(in) :: stock_data3d(:,:,:) !< data array is 3d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4455,7 +4455,7 @@ subroutine stock_move_3d(from, to, grid_index, data, xmap, & endif from_dq = delta_t * 4.0_r8_kind * PI * radius**2 * sum( sum(xmap%grids(grid_index)%area * & - & sum(xmap%grids(grid_index)%frac_area * data, DIM=3), DIM=1)) + & sum(xmap%grids(grid_index)%frac_area * stock_data3d, DIM=3), DIM=1)) to_dq = from_dq ! update only if argument is present. @@ -4478,7 +4478,7 @@ end subroutine stock_move_3d !> @brief this version takes rank 2 data, it can be used to compute the flux on the atmos side !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_2d(from, to, grid_index, data, xmap, & +subroutine stock_move_2d(from, to, grid_index, stock_data2d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 2 data, it can be used to compute the flux on the atmos side @@ -4490,7 +4490,7 @@ subroutine stock_move_2d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, optional, intent(in) :: grid_index - real(r8_kind), intent(in) :: data(:,:) !< data array is 2d + real(r8_kind), intent(in) :: stock_data2d(:,:) !< data array is 2d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4511,7 +4511,7 @@ subroutine stock_move_2d(from, to, grid_index, data, xmap, & if( .not. present(grid_index) .or. grid_index==1 ) then ! only makes sense if grid_index == 1 - from_dq = delta_t * 4.0_r8_kind*PI*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) + from_dq = delta_t * 4.0_r8_kind*PI*radius**2 * sum(sum(xmap%grids(1)%area * stock_data2d, DIM=1)) to_dq = from_dq else @@ -4542,7 +4542,7 @@ end subroutine stock_move_2d !! first grid, which typically is on the atmos side. !! note that "from" and "to" are optional, the stocks will be subtracted, resp. added, only !! if these are present. -subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & +subroutine stock_move_ug_3d(from, to, grid_index, stock_ug_data3d, xmap, & & delta_t, from_side, to_side, radius, verbose, ier) ! this version takes rank 3 data, it can be used to compute the flux on anything but the @@ -4555,7 +4555,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & type(stock_type), intent(inout), optional :: from, to integer, intent(in) :: grid_index !< grid index - real(r8_kind), intent(in) :: data(:,:) !< data array is 3d + real(r8_kind), intent(in) :: stock_ug_data3d(:,:) !< data array is 3d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t integer, intent(in) :: from_side !< ISTOCK_TOP, ISTOCK_BOTTOM, or ISTOCK_SIDE @@ -4563,7 +4563,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & real(r8_kind), intent(in) :: radius !< earth radius character(len=*), intent(in), optional :: verbose integer, intent(out) :: ier - real(r8_kind), dimension(size(data,1),size(data,2)) :: tmp + real(r8_kind), dimension(size(stock_ug_data3d,1),size(stock_ug_data3d,2)) :: tmp real(r8_kind) :: from_dq, to_dq @@ -4579,7 +4579,7 @@ subroutine stock_move_ug_3d(from, to, grid_index, data, xmap, & return endif - tmp = xmap%grids(grid_index)%frac_area(:,1,:) * data + tmp = xmap%grids(grid_index)%frac_area(:,1,:) * stock_ug_data3d from_dq = delta_t * 4.0_r8_kind * PI * radius**2 * sum( xmap%grids(grid_index)%area(:,1) * & & sum(tmp, DIM=2)) to_dq = from_dq @@ -4604,13 +4604,13 @@ end subroutine stock_move_ug_3d !####################################################################### !> @brief surface/time integral of a 2d array -subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier) +subroutine stock_integrate_2d(integrate_data2d, xmap, delta_t, radius, res, ier) ! surface/time integral of a 2d array use mpp_mod, only : mpp_sum - real(r8_kind), intent(in) :: data(:,:) !< data array is 2d + real(r8_kind), intent(in) :: integrate_data2d(:,:) !< data array is 2d type(xmap_type), intent(in) :: xmap real(r8_kind), intent(in) :: delta_t real(r8_kind), intent(in) :: radius !< earth radius @@ -4625,7 +4625,7 @@ subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier) return endif - res = delta_t * 4.0_r8_kind * PI * radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) + res = delta_t * 4.0_r8_kind * PI * radius**2 * sum(sum(xmap%grids(1)%area * integrate_data2d, DIM=1)) end subroutine stock_integrate_2d !####################################################################### diff --git a/horiz_interp/include/horiz_interp_conserve.inc b/horiz_interp/include/horiz_interp_conserve.inc index 3fe5168e4b..0ec17fcacd 100644 --- a/horiz_interp/include/horiz_interp_conserve.inc +++ b/horiz_interp/include/horiz_interp_conserve.inc @@ -881,18 +881,18 @@ subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, l !####################################################################### !> sums up the data and weights for a single output grid box - subroutine DATA_SUM_( data, area, facis, facie, facjs, facje, & + subroutine DATA_SUM_( grid_data, area, facis, facie, facjs, facje, & dwtsum, wtsum, arsum, mask ) !----------------------------------------------------------------------- - real(FMS_HI_KIND_), intent(in), dimension(:,:) :: data, area + real(FMS_HI_KIND_), intent(in), dimension(:,:) :: grid_data, area real(FMS_HI_KIND_), intent(in) :: facis, facie, facjs, facje real(FMS_HI_KIND_), intent(inout) :: dwtsum, wtsum, arsum real(FMS_HI_KIND_), intent(in), optional :: mask(:,:) ! fac__ = fractional portion of each boundary grid box included ! in the integral - ! dwtsum = sum(data*area*mask) + ! dwtsum = sum(grid_data*area*mask) ! wtsum = sum(area*mask) ! arsum = sum(area) !----------------------------------------------------------------------- @@ -914,10 +914,10 @@ subroutine HORIZ_INTERP_CONSERVE_NEW_1DX1D_ ( Interp, lon_in, lat_in, lon_out, l if (present(mask)) then wt = wt * mask - dwtsum = dwtsum + sum(wt*data) + dwtsum = dwtsum + sum(wt*grid_data) wtsum = wtsum + sum(wt) else - dwtsum = dwtsum + sum(wt*data) + dwtsum = dwtsum + sum(wt*grid_data) wtsum = wtsum + asum endif !----------------------------------------------------------------------- diff --git a/interpolator/include/interpolator.inc b/interpolator/include/interpolator.inc index 3dace5ab6a..754bae35cf 100644 --- a/interpolator/include/interpolator.inc +++ b/interpolator/include/interpolator.inc @@ -601,7 +601,7 @@ select case(ntime) if (non_monthly) then ! We have a broken time-line. e.g. We have monthly data but only for years ending in 0. 1960,1970 etc. -! allocate(clim_type%data(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, num_fields)) +! allocate(clim_type%data5d(size(lonb_mod(:))-1, size(latb_mod(:))-1, nlev, 2, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%pmon_pyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%pmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) allocate(clim_type%FMS_INTP_TYPE_%nmon_nyear(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, num_fields)) @@ -614,12 +614,12 @@ select case(ntime) else ! We have a continuous time-line so treat as for 5-12 timelevels as below. if ( .not. read_all_on_init) then - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) else - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & ntime, num_fields)) endif - clim_type%FMS_INTP_TYPE_%data = 0.0_lkind + clim_type%FMS_INTP_TYPE_%data5d = 0.0_lkind clim_type%TIME_FLAG = LINEAR endif @@ -631,26 +631,26 @@ endif ! Assume we have monthly or higher time resolution datasets (climatology or time series) ! So we only need to read 2 datasets and apply linear temporal interpolation. if ( .not. read_all_on_init) then - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 2, num_fields)) else - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, & ntime, num_fields)) endif - clim_type%FMS_INTP_TYPE_%data = 0.0_lkind + clim_type%FMS_INTP_TYPE_%data5d = 0.0_lkind clim_type%TIME_FLAG = LINEAR !++lwh !case (1:4) ! Assume we have seasonal data and read in all the data. ! We can apply sine curves to these data. -! allocate(clim_type%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, num_fields)) -! clim_type%data = 0.0 +! allocate(clim_type%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, ntime, num_fields)) +! clim_type%data5d = 0.0 ! clim_type%TIME_FLAG = SEASONAL !--lwh ! case (default) case(:0) clim_type%TIME_FLAG = NOTIME - allocate(clim_type%FMS_INTP_TYPE_%data(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields)) + allocate(clim_type%FMS_INTP_TYPE_%data5d(size(lonb_mod,1)-1, size(latb_mod,2)-1, nlev, 1, num_fields)) end select @@ -777,7 +777,7 @@ if( clim_type%TIME_FLAG .eq. SEASONAL ) then do i=1,num_fields do n = 1, ntime call read_data( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,n,i), n, i, base_time ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,n,i), n, i, base_time ) enddo enddo endif @@ -787,7 +787,7 @@ if( clim_type%TIME_FLAG .eq. LINEAR .and. read_all_on_init) then do i=1,num_fields do n = 1, ntime call read_data( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,n,i), n, i, base_time ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,n,i), n, i, base_time ) enddo enddo @@ -798,7 +798,7 @@ if( clim_type%TIME_FLAG .eq. NOTIME ) then ! Read all the data at this point. do i=1,num_fields call read_data_no_time_axis( clim_type, clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), i ) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), i ) enddo call close_file (fileobj) endif @@ -809,14 +809,14 @@ endif end subroutine FMS2IO_INTERPOLATOR_INIT_ -subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) +subroutine GET_AXIS_LATLON_DATA_(fileobj, name, latlon_data) type(FmsNetcdfFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(FMS_INTP_KIND_), dimension(:), intent(out) :: data + real(FMS_INTP_KIND_), dimension(:), intent(out) :: latlon_data if(variable_exists(fileobj, name)) then - call fms2_io_read_data(fileobj, name, data) + call fms2_io_read_data(fileobj, name, latlon_data) else call mpp_error(FATAL,'get_axis_latlon_data: variable '// & & trim(name)//' does not exist in file '//trim(fileobj%path) ) @@ -824,7 +824,7 @@ subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) call get_variable_units(fileobj, name, units) select case(units(1:6)) case('degree') - data = data*real(DTR,FMS_INTP_KIND_) + latlon_data = latlon_data*real(DTR,FMS_INTP_KIND_) case('radian') case default call mpp_error(FATAL, "get_axis_latlon_data : Units for '// & @@ -834,10 +834,10 @@ subroutine GET_AXIS_LATLON_DATA_(fileobj, name, data) end subroutine GET_AXIS_LATLON_DATA_ -subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indices) +subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, level_data, level_type, vertical_indices) type(FmsNetcdfFile_t), intent(in) :: fileobj character(len=*), intent(in) :: name - real(FMS_INTP_KIND_), dimension(:), intent(out) :: data + real(FMS_INTP_KIND_), dimension(:), intent(out) :: level_data integer, intent(out) :: level_type, vertical_indices real(FMS_INTP_KIND_), dimension(:), allocatable :: alpha integer :: n, nlev @@ -845,7 +845,7 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice integer, parameter :: lkind=FMS_INTP_KIND_ if(variable_exists(fileobj, name)) then - call fms2_io_read_data(fileobj, name, data) + call fms2_io_read_data(fileobj, name, level_data) else call mpp_error(FATAL,'get_axis_level_data: variable '// & & trim(name)//' does not exist in file '//trim(fileobj%path) ) @@ -854,9 +854,9 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice level_type = PRESSURE ! Convert to Pa if( trim(adjustl(lowercase(chomp(units)))) == "mb" .or. trim(adjustl(lowercase(chomp(units)))) == "hpa") then - data = data * 100._lkind + level_data = level_data * 100._lkind endif - nlev = size(data(:)) + nlev = size(level_data(:)) sense = get_variable_sense(fileobj, name) ! define the direction of the vertical data axis ! switch index order if necessary so that indx 1 is at lowest pressure, @@ -865,10 +865,10 @@ subroutine GET_AXIS_LEVEL_DATA_(fileobj, name, data, level_type, vertical_indice vertical_indices = INCREASING_UPWARD allocate (alpha(nlev)) do n = 1, nlev - alpha(n) = data(nlev-n+1) + alpha(n) = level_data(nlev-n+1) end do do n = 1, nlev - data(n) = alpha(n) + level_data(n) = alpha(n) end do deallocate (alpha) else @@ -1314,10 +1314,10 @@ integer, parameter :: lkind=FMS_INTP_KIND_ ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. do i=1, size(clim_type%field_name(:)) - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 end do @@ -1333,7 +1333,7 @@ integer, parameter :: lkind=FMS_INTP_KIND_ if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do endif @@ -1663,10 +1663,10 @@ if ( .not. clim_type%separate_time_vary_calc) then ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. do i=1, size(clim_type%field_name(:)) - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 end do @@ -1682,7 +1682,7 @@ if ( .not. clim_type%separate_time_vary_calc) then if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 do i=1, size(clim_type%field_name(:)) call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup end do endif @@ -1698,9 +1698,9 @@ select case(clim_type%TIME_FLAG) case (LINEAR) do n=1, size(clim_type%field_name(:)) hinterp_data(:,:,:,n) = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight)* & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,n) + & + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,n) + & clim_type%FMS_INTP_TYPE_%tweight* & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,n) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaup,n) end do ! case (SEASONAL) ! Do sine fit to data at this point @@ -2119,10 +2119,10 @@ if ( .not. clim_type%separate_time_vary_calc) then !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 @@ -2136,7 +2136,7 @@ if ( .not. clim_type%separate_time_vary_calc) then clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup endif @@ -2147,9 +2147,9 @@ if ( .not. clim_type%separate_time_vary_calc) then select case(clim_type%TIME_FLAG) case (LINEAR) hinterp_data = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight) * & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,i) + & + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,i) + & clim_type%FMS_INTP_TYPE_%tweight * & - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,i) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaup,i) ! case (SEASONAL) ! Do sine fit to data at this point case (BILINEAR) @@ -2574,10 +2574,10 @@ if ( .not. clim_type%separate_time_vary_calc) then !Set up ! field(:,:,:,1) as the previous time slice. ! field(:,:,:,2) as the next time slice. - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,1,i), taum,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,1,i), taum,i,Time) clim_type%time_init(i,1) = taum clim_type%itaum = 1 - call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data(:,:,:,2,i), taup,i,Time) + call read_data(clim_type,clim_type%field_name(i), clim_type%FMS_INTP_TYPE_%data5d(:,:,:,2,i), taup,i,Time) clim_type%time_init(i,2) = taup clim_type%itaup = 2 endif ! clim_type%itaum.eq.clim_type%itaup.eq.0 @@ -2591,7 +2591,7 @@ if ( .not. clim_type%separate_time_vary_calc) then clim_type%itaup = 1 if (clim_type%itaum .eq. 1 ) clim_type%itaup = 2 call read_data(clim_type,clim_type%field_name(i), & - clim_type%FMS_INTP_TYPE_%data(:,:,:,clim_type%itaup,i), taup,i, Time) + clim_type%FMS_INTP_TYPE_%data5d(:,:,:,clim_type%itaup,i), taup,i, Time) clim_type%time_init(i,clim_type%itaup)=taup endif endif! TIME_FLAG .eq. LINEAR .and. (.not. read_all_on_init) @@ -2603,8 +2603,9 @@ if ( .not. clim_type%separate_time_vary_calc) then select case(clim_type%TIME_FLAG) case (LINEAR) hinterp_data = (1._lkind-clim_type%FMS_INTP_TYPE_%tweight)*& - clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaum,i) & - + clim_type%FMS_INTP_TYPE_%tweight*clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,clim_type%itaup,i) + clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,clim_type%itaum,i) & + + clim_type%FMS_INTP_TYPE_%tweight*clim_type%FMS_INTP_TYPE_%data5d & + (istart:iend,jstart:jend,:,clim_type%itaup,i) ! case (SEASONAL) ! Do sine fit to data at this point case (BILINEAR) @@ -2743,7 +2744,7 @@ if(present(clim_units)) then endif do n=1, size(clim_type%field_name(:)) - hinterp_data(:,:,:,n) = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,n) + hinterp_data(:,:,:,n) = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,n) end do select case(clim_type%level_type) @@ -2894,7 +2895,7 @@ do i= 1,size(clim_type%field_name(:)) clim_units = chomp(clim_units) endif - hinterp_data = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,i) + hinterp_data = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,i) select case(clim_type%level_type) case(PRESSURE) @@ -3024,7 +3025,7 @@ do i= 1,size(clim_type%field_name(:)) clim_units = chomp(clim_units) endif - hinterp_data = clim_type%FMS_INTP_TYPE_%data(istart:iend,jstart:jend,:,1,i) + hinterp_data = clim_type%FMS_INTP_TYPE_%data5d(istart:iend,jstart:jend,:,1,i) interp_data(:,:) = hinterp_data(:,:,1) diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index c9815dc886..f598e2e56e 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -254,7 +254,7 @@ module interpolator_mod real(r4_kind), allocatable :: lonb(:) !< No description real(r4_kind), allocatable :: levs(:) !< No description real(r4_kind), allocatable :: halflevs(:) !< No description -real(r4_kind), allocatable :: data(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) +real(r4_kind), allocatable :: data5d(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) real(r4_kind), allocatable :: pmon_pyear(:,:,:,:) !< No description real(r4_kind), allocatable :: pmon_nyear(:,:,:,:) !< No description real(r4_kind), allocatable :: nmon_nyear(:,:,:,:) !< No description @@ -273,7 +273,7 @@ module interpolator_mod real(r8_kind), allocatable :: lonb(:) !< No description real(r8_kind), allocatable :: levs(:) !< No description real(r8_kind), allocatable :: halflevs(:) !< No description -real(r8_kind), allocatable :: data(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) +real(r8_kind), allocatable :: data5d(:,:,:,:,:) !< (nlatmod,nlonmod,nlevclim,size(time_init,2),nfields) real(r8_kind), allocatable :: pmon_pyear(:,:,:,:) !< No description real(r8_kind), allocatable :: pmon_nyear(:,:,:,:) !< No description real(r8_kind), allocatable :: nmon_nyear(:,:,:,:) !< No description @@ -451,13 +451,13 @@ subroutine interpolate_type_eq (Out, In) if (allocated(In%out_of_bounds)) Out%out_of_bounds = In%out_of_bounds if (allocated(In%vert_interp )) Out%vert_interp = In%vert_interp if(In%r4_type%is_allocated) then - if (allocated(In%r4_type%data )) Out%r4_type%data = In%r4_type%data + if (allocated(In%r4_type%data5d )) Out%r4_type%data5d = In%r4_type%data5d if (allocated(In%r4_type%pmon_pyear )) Out%r4_type%pmon_pyear = In%r4_type%pmon_pyear if (allocated(In%r4_type%pmon_nyear )) Out%r4_type%pmon_nyear = In%r4_type%pmon_nyear if (allocated(In%r4_type%nmon_nyear )) Out%r4_type%nmon_nyear = In%r4_type%nmon_nyear if (allocated(In%r4_type%nmon_pyear )) Out%r4_type%nmon_pyear = In%r4_type%nmon_pyear else if(In%r8_type%is_allocated) then - if (allocated(In%r8_type%data )) Out%r8_type%data = In%r8_type%data + if (allocated(In%r8_type%data5d )) Out%r8_type%data5d = In%r8_type%data5d if (allocated(In%r8_type%pmon_pyear )) Out%r8_type%pmon_pyear = In%r8_type%pmon_pyear if (allocated(In%r8_type%pmon_nyear )) Out%r8_type%pmon_nyear = In%r8_type%pmon_nyear if (allocated(In%r8_type%nmon_nyear )) Out%r8_type%nmon_nyear = In%r8_type%nmon_nyear @@ -668,7 +668,7 @@ subroutine interpolator_end(clim_type) if (allocated (clim_type%r4_type%lonb )) deallocate(clim_type%r4_type%lonb) if (allocated (clim_type%r4_type%levs )) deallocate(clim_type%r4_type%levs) if (allocated (clim_type%r4_type%halflevs)) deallocate(clim_type%r4_type%halflevs) - if (allocated (clim_type%r4_type%data)) deallocate(clim_type%r4_type%data) + if (allocated (clim_type%r4_type%data5d )) deallocate(clim_type%r4_type%data5d) else if(clim_type%r8_type%is_allocated) then if (allocated (clim_type%r8_type%lat )) deallocate(clim_type%r8_type%lat) if (allocated (clim_type%r8_type%lon )) deallocate(clim_type%r8_type%lon) @@ -676,7 +676,7 @@ subroutine interpolator_end(clim_type) if (allocated (clim_type%r8_type%lonb )) deallocate(clim_type%r8_type%lonb) if (allocated (clim_type%r8_type%levs )) deallocate(clim_type%r8_type%levs) if (allocated (clim_type%r8_type%halflevs)) deallocate(clim_type%r8_type%halflevs) - if (allocated (clim_type%r8_type%data)) deallocate(clim_type%r8_type%data) + if (allocated (clim_type%r8_type%data5d)) deallocate(clim_type%r8_type%data5d) end if if (allocated (clim_type%time_slice)) deallocate(clim_type%time_slice) diff --git a/mpp/include/mpp_comm_mpi.inc b/mpp/include/mpp_comm_mpi.inc index 928f9fcb92..d7fd2352ae 100644 --- a/mpp/include/mpp_comm_mpi.inc +++ b/mpp/include/mpp_comm_mpi.inc @@ -319,13 +319,13 @@ end subroutine mpp_exit ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Broadcasts a character string from the given pe to it's pelist - subroutine mpp_broadcast_char(data, length, from_pe, pelist ) - character(len=*), intent(inout) :: data(:) !< Character string to send + subroutine mpp_broadcast_char(char_data, length, from_pe, pelist ) + character(len=*), intent(inout) :: char_data(:) !< Character string to send integer, intent(in) :: length !< length of given data to broadcast integer, intent(in) :: from_pe !< pe to broadcast from integer, intent(in), optional :: pelist(:) !< optional pelist to broadcast to integer :: n, i, from_rank - character :: str1D(length*size(data(:))) + character :: str1D(length*size(char_data(:))) pointer(lptr, str1D) if( .NOT.module_is_initialized )call mpp_error( FATAL, 'mpp_broadcast_text: You must first call mpp_init.' ) @@ -351,8 +351,9 @@ end subroutine mpp_exit exit endif enddo - lptr = LOC (data) - if( mpp_npes().GT.1 ) call MPI_BCAST( data, length*size(data(:)), MPI_CHARACTER, from_rank, peset(n)%id, error ) + lptr = LOC (char_data) + if( mpp_npes().GT.1 ) call MPI_BCAST( char_data, length*size(char_data(:)), & + MPI_CHARACTER, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length ) return end subroutine mpp_broadcast_char diff --git a/mpp/include/mpp_comm_nocomm.inc b/mpp/include/mpp_comm_nocomm.inc index a1d849b831..895e8130e0 100644 --- a/mpp/include/mpp_comm_nocomm.inc +++ b/mpp/include/mpp_comm_nocomm.inc @@ -244,8 +244,8 @@ end subroutine mpp_exit return end subroutine mpp_set_stack_size - subroutine mpp_broadcast_char(data, length, from_pe, pelist ) - character(len=*), intent(inout) :: data(:) + subroutine mpp_broadcast_char(char_data, length, from_pe, pelist ) + character(len=*), intent(inout) :: char_data(:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index e8eea60d00..883f68814c 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -1350,22 +1350,22 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) end subroutine compute_overlap_fine_to_coarse -function find_index(array, data, start_pos) +function find_index(array, index_data, start_pos) integer, intent(in) :: array(:) - integer, intent(in) :: data + integer, intent(in) :: index_data integer, intent(in) :: start_pos integer :: find_index integer :: i find_index = 0 do i = start_pos, size(array) - if(array(i) == data) then + if(array(i) == index_data) then find_index = i exit endif enddo if(find_index == 0) then - print*, "start_pos = ", start_pos, data, array + print*, "start_pos = ", start_pos, index_data, array call mpp_error(FATAL, "mpp_define_nest_domains.inc: can not find data in array") endif diff --git a/mpp/include/mpp_do_get_boundary.fh b/mpp/include/mpp_do_get_boundary.fh index f346e6e629..a8c683bbf8 100644 --- a/mpp/include/mpp_do_get_boundary.fh +++ b/mpp/include/mpp_do_get_boundary.fh @@ -1012,7 +1012,7 @@ subroutine MPP_DO_GET_BOUNDARY_3D_V_(f_addrsx, f_addrsy, domain, boundx, boundy, tMe = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 diff --git a/mpp/include/mpp_do_get_boundary_ad.fh b/mpp/include/mpp_do_get_boundary_ad.fh index b2595e041a..b4d83786d6 100644 --- a/mpp/include/mpp_do_get_boundary_ad.fh +++ b/mpp/include/mpp_do_get_boundary_ad.fh @@ -580,7 +580,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun tMe = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 diff --git a/mpp/include/mpp_do_global_field.fh b/mpp/include/mpp_do_global_field.fh index f38d4054e1..7dfe2ab42b 100644 --- a/mpp/include/mpp_do_global_field.fh +++ b/mpp/include/mpp_do_global_field.fh @@ -107,8 +107,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') @@ -374,8 +374,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. & size(local,2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin - joff = -domain%y(tile)%data%begin + ioff = -domain%x(tile)%domain_data%begin + joff = -domain%y(tile)%domain_data%begin else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.' ) diff --git a/mpp/include/mpp_do_global_field_ad.fh b/mpp/include/mpp_do_global_field_ad.fh index d32e6aa4b8..cb635cae11 100644 --- a/mpp/include/mpp_do_global_field_ad.fh +++ b/mpp/include/mpp_do_global_field_ad.fh @@ -109,8 +109,8 @@ else if( size(local,1).EQ.(domain%x(tile)%memory%size+ishift) .AND. size(local, & & 2).EQ.(domain%y(tile)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_FIELD_: incoming field array must match either compute domain or memory domain.') diff --git a/mpp/include/mpp_do_redistribute.fh b/mpp/include/mpp_do_redistribute.fh index cf812b721c..26c9dc9ff3 100644 --- a/mpp/include/mpp_do_redistribute.fh +++ b/mpp/include/mpp_do_redistribute.fh @@ -22,11 +22,11 @@ integer(i8_kind), intent(in) :: f_in(:), f_out(:) type(DomainCommunicator2D), intent(in) :: d_comm MPP_TYPE_, intent(in) :: d_type - MPP_TYPE_ :: field_in(d_comm%domain_in%x(1)%data%begin:d_comm%domain_in%x(1)%data%end, & - d_comm%domain_in%y(1)%data%begin:d_comm%domain_in%y(1)%data%end,d_comm%ke) + MPP_TYPE_ :: field_in(d_comm%domain_in%x(1)%domain_data%begin:d_comm%domain_in%x(1)%domain_data%end, & + d_comm%domain_in%y(1)%domain_data%begin:d_comm%domain_in%y(1)%domain_data%end,d_comm%ke) pointer( ptr_field_in, field_in) - MPP_TYPE_ :: field_out(d_comm%domain_out%x(1)%data%begin:d_comm%domain_out%x(1)%data%end, & - d_comm%domain_out%y(1)%data%begin:d_comm%domain_out%y(1)%data%end,d_comm%ke) + MPP_TYPE_ :: field_out(d_comm%domain_out%x(1)%domain_data%begin:d_comm%domain_out%x(1)%domain_data%end, & + d_comm%domain_out%y(1)%domain_data%begin:d_comm%domain_out%y(1)%domain_data%end,d_comm%ke) pointer( ptr_field_out, field_out) type(domain2D), pointer :: domain_in, domain_out integer :: i, j, k, l, n, l_size diff --git a/mpp/include/mpp_do_updateV.fh b/mpp/include/mpp_do_updateV.fh index 4009cd2b1b..adc509b3fb 100644 --- a/mpp/include/mpp_do_updateV.fh +++ b/mpp/include/mpp_do_updateV.fh @@ -843,7 +843,7 @@ is = domain%x(1)%global%begin - 1 end if if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) @@ -859,7 +859,7 @@ case(CGRID_NE) is = domain%x(1)%global%begin if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) @@ -908,14 +908,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -936,15 +937,15 @@ select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -953,13 +954,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -970,8 +971,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -1003,14 +1004,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1031,15 +1033,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1048,13 +1050,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1065,8 +1067,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -1098,14 +1100,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1126,15 +1129,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1143,13 +1146,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1160,8 +1163,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_do_updateV_ad.fh b/mpp/include/mpp_do_updateV_ad.fh index 8d230f501c..f1d11ec809 100644 --- a/mpp/include/mpp_do_updateV_ad.fh +++ b/mpp/include/mpp_do_updateV_ad.fh @@ -403,7 +403,8 @@ if(domain%symmetry) shift = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(update_flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift ) then !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -411,7 +412,7 @@ is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -436,15 +437,15 @@ else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k) end do @@ -453,13 +454,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) end do end do @@ -470,8 +471,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -503,14 +504,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -531,15 +533,15 @@ select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(2*is-i,j,k) = fieldx(2*is-i,j,k) + fieldx(i,j,k) fieldy(2*is-i,j,k) = fieldy(2*is-i,j,k) + fieldy(i,j,k) end do @@ -548,13 +550,13 @@ end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(2*is-i-1,j,k) = fieldy(2*is-i-1,j,k) + fieldy(i,j,k) end do end do @@ -565,8 +567,8 @@ !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -598,14 +600,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -626,15 +629,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k) end do @@ -643,13 +646,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) end do end do @@ -660,8 +663,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -693,14 +696,15 @@ !! boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -721,15 +725,15 @@ select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,2*js-j,k) = fieldx(i,2*js-j,k) + fieldx(i,j,k) fieldy(i,2*js-j,k) = fieldy(i,2*js-j,k) + fieldy(i,j,k) end do @@ -738,13 +742,13 @@ end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_AD_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i, 2*js-j-1,k) = fieldx(i, 2*js-j-1,k) + fieldx(i,j,k) end do end do @@ -755,8 +759,8 @@ !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_do_updateV_nonblock.fh b/mpp/include/mpp_do_updateV_nonblock.fh index aa4a83607d..7ae9e73f14 100644 --- a/mpp/include/mpp_do_updateV_nonblock.fh +++ b/mpp/include/mpp_do_updateV_nonblock.fh @@ -707,7 +707,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u if(domain%symmetry) shift = 1 if( BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -715,7 +715,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -740,9 +740,9 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,l_size @@ -750,7 +750,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -759,14 +759,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -777,8 +777,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -809,14 +809,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,SOUTH) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---southern boundary fold ! NOTE: symmetry is assumed for fold-south boundary j = domain%y(1)%global%begin - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then j = domain%y(1)%global%begin is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -837,15 +837,15 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -854,14 +854,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) is = domain%x(1)%global%begin - if( is.GT.domain%x(1)%data%begin )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( is.GT.domain%x(1)%domain_data%begin )then + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO_UPDATE_V: folded-south CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldy(i,j,k) = fieldy(2*is-i-1,j,k) end do end do @@ -872,8 +872,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then - ie = domain%x(1)%data%end + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then + ie = domain%x(1)%domain_data%end is = is + 1 select case(gridtype) case(BGRID_NE) @@ -904,14 +904,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,WEST) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---eastern boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%begin - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%begin js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -932,16 +932,16 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -950,14 +950,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-west CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -968,8 +968,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) @@ -1000,14 +1000,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u else if( BTEST(domain%fold,EAST) .AND. (.NOT.BTEST(flags,SCALAR_BIT)) )then ! ---eastern boundary fold ! NOTE: symmetry is assumed for fold-west boundary i = domain%x(1)%global%end+shift - if( domain%x(1)%data%begin.LE.i .AND. i.LE.domain%x(1)%data%end+shift )then !fold is within domain + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE.domain%x(1)%domain_data%end+shift )then !fold is within domain midpoint = (domain%y(1)%global%begin+domain%y(1)%global%end-1+shift)/2 !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then i = domain%x(1)%global%end+shift js = domain%y(1)%global%begin; je = domain%y(1)%global%end+shift do j = js ,je, midpoint - if( domain%y(1)%data%begin.LE.j .AND. j.LE. domain%y(1)%data%end+shift )then + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE. domain%y(1)%domain_data%end+shift )then do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) @@ -1028,16 +1028,16 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u select case(gridtype) case(BGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then + if( js.GT.domain%y(1)%domain_data%begin )then - if( 2*js-domain%y(1)%data%begin.GT.domain%y(1)%data%end+shift ) & + if( 2*js-domain%y(1)%domain_data%begin.GT.domain%y(1)%domain_data%end+shift ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east BGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) ptr_fieldy = f_addrsy(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i,2*js-j,k) fieldy(i,j,k) = fieldy(i,2*js-j,k) end do @@ -1046,14 +1046,14 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u end if case(CGRID_NE) js = domain%y(1)%global%begin - if( js.GT.domain%y(1)%data%begin )then - if( 2*js-domain%y(1)%data%begin-1.GT.domain%y(1)%data%end ) & + if( js.GT.domain%y(1)%domain_data%begin )then + if( 2*js-domain%y(1)%domain_data%begin-1.GT.domain%y(1)%domain_data%end ) & call mpp_error( FATAL, & & 'MPP_COMPLETE_DO__UPDATE_V: folded-east CGRID_NE west edge ubound error.' ) do l=1,l_size ptr_fieldx = f_addrsx(l, 1) do k = 1,ke_list(l,tMe) - do j = domain%y(1)%data%begin,js-1 + do j = domain%y(1)%domain_data%begin,js-1 fieldx(i,j,k) = fieldx(i, 2*js-j-1,k) end do end do @@ -1064,8 +1064,8 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u !off north edge js = domain%y(1)%global%end - if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%data%end )then - je = domain%y(1)%data%end + if(domain%y(1)%cyclic .AND. js.LT.domain%y(1)%domain_data%end )then + je = domain%y(1)%domain_data%end js = js + 1 select case(gridtype) case(BGRID_NE) diff --git a/mpp/include/mpp_domains_comm.inc b/mpp/include/mpp_domains_comm.inc index a092aaf41c..10940e048a 100644 --- a/mpp/include/mpp_domains_comm.inc +++ b/mpp/include/mpp_domains_comm.inc @@ -71,11 +71,11 @@ & 'MPP_REDISTRIBUTE_INIT_COMM: either domain_in or domain_out must be native.' ) !check sizes if( domain_in%pe /= NULL_PE )then - if( isize_in /= domain_in%x(1)%data%size .OR. jsize_in /= domain_in%y(1)%data%size ) & + if( isize_in /= domain_in%x(1)%domain_data%size .OR. jsize_in /= domain_in%y(1)%domain_data%size ) & call mpp_error( FATAL, 'MPP_REDISTRIBUTE_INIT_COMM: field_in must be on data domain of domain_in.' ) end if if( domain_out%pe /= NULL_PE )then - if( isize_out /= domain_out%x(1)%data%size .OR. jsize_out /= domain_out%y(1)%data%size ) & + if( isize_out /= domain_out%x(1)%domain_data%size .OR. jsize_out /= domain_out%y(1)%domain_data%size ) & call mpp_error( FATAL, 'MPP_REDISTRIBUTE_INIT_COMM: field_out must be on data domain of domain_out.' ) end if @@ -115,8 +115,8 @@ d_comm%S_msize=0 d_comm%S_do_buf=.false. - ioff = domain_in%x(1)%data%begin - joff = domain_in%y(1)%data%begin + ioff = domain_in%x(1)%domain_data%begin + joff = domain_in%y(1)%domain_data%begin mytile = domain_in%tile_id(1) call mpp_get_compute_domain( domain_in, isc, iec, jsc, jec ) @@ -256,8 +256,8 @@ joff = -domain%y(1)%compute%begin + 1 elseif( isize_l == (domain%x(1)%memory%size+ishift) .AND. jsize_l == (domain%y(1)%memory%size+jshift) )then !local is on data domain - ioff = -domain%x(1)%data%begin + 1 - joff = -domain%y(1)%data%begin + 1 + ioff = -domain%x(1)%domain_data%begin + 1 + joff = -domain%y(1)%domain_data%begin + 1 else call mpp_error(FATAL, & & 'MPP_GLOBAL_FIELD_INIT_COMM: incoming field array must match either compute domain or data domain.') diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index 8e1f895eec..b606aa3d20 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -408,41 +408,41 @@ !get data domain !data domain is at least equal to compute domain - domain%list(:)%data%begin = domain%list(:)%compute%begin - domain%list(:)%data%end = domain%list(:)%compute%end - domain%list(:)%data%is_global = .FALSE. + domain%list(:)%domain_data%begin = domain%list(:)%compute%begin + domain%list(:)%domain_data%end = domain%list(:)%compute%end + domain%list(:)%domain_data%is_global = .FALSE. !apply global flags if( data_domain_is_global )then - domain%list(:)%data%begin = isg - domain%list(:)%data%end = ieg - domain%list(:)%data%is_global = .TRUE. + domain%list(:)%domain_data%begin = isg + domain%list(:)%domain_data%end = ieg + domain%list(:)%domain_data%is_global = .TRUE. end if !apply margins - domain%list(:)%data%begin = domain%list(:)%data%begin - halobegin - domain%list(:)%data%end = domain%list(:)%data%end + haloend - domain%list(:)%data%size = domain%list(:)%data%end - domain%list(:)%data%begin + 1 + domain%list(:)%domain_data%begin = domain%list(:)%domain_data%begin - halobegin + domain%list(:)%domain_data%end = domain%list(:)%domain_data%end + haloend + domain%list(:)%domain_data%size = domain%list(:)%domain_data%end - domain%list(:)%domain_data%begin + 1 !--- define memory domain, if memory_size is not present or memory size is 0, memory domain size !--- will be the same as data domain size. if momory_size is present, memory_size should greater than !--- or equal to data size. The begin of memory domain will be always the same as data domain. - domain%list(:)%memory%begin = domain%list(:)%data%begin - domain%list(:)%memory%end = domain%list(:)%data%end + domain%list(:)%memory%begin = domain%list(:)%domain_data%begin + domain%list(:)%memory%end = domain%list(:)%domain_data%end if( present(memory_size) ) then if(memory_size > 0) then - if( domain%list(domain%pos)%data%size > memory_size ) call mpp_error(FATAL, & + if( domain%list(domain%pos)%domain_data%size > memory_size ) call mpp_error(FATAL, & "mpp_domains_define.inc: data domain size is larger than memory domain size on this pe") domain%list(:)%memory%end = domain%list(:)%memory%begin + memory_size - 1 end if end if domain%list(:)%memory%size = domain%list(:)%memory%end - domain%list(:)%memory%begin + 1 - domain%list(:)%memory%is_global = domain%list(:)%data%is_global + domain%list(:)%memory%is_global = domain%list(:)%domain_data%is_global domain%compute = domain%list(domain%pos)%compute - domain%data = domain%list(domain%pos)%data + domain%domain_data = domain%list(domain%pos)%domain_data domain%global = domain%list(domain%pos)%global domain%memory = domain%list(domain%pos)%memory domain%compute%max_size = MAXVAL( domain%list(:)%compute%size ) - domain%data%max_size = MAXVAL( domain%list(:)%data%size ) + domain%domain_data%max_size = MAXVAL( domain%list(:)%domain_data%size ) domain%global%max_size = domain%global%size domain%memory%max_size = domain%memory%size @@ -565,10 +565,10 @@ enddo io_domain%pos = n io_domain%x(1)%compute = domain%x(1)%compute - io_domain%x(1)%data = domain%x(1)%data + io_domain%x(1)%domain_data = domain%x(1)%domain_data io_domain%x(1)%memory = domain%x(1)%memory io_domain%y(1)%compute = domain%y(1)%compute - io_domain%y(1)%data = domain%y(1)%data + io_domain%y(1)%domain_data = domain%y(1)%domain_data io_domain%y(1)%memory = domain%y(1)%memory io_domain%x(1)%global%begin = domain%x(1)%list(ipos_beg)%compute%begin io_domain%x(1)%global%end = domain%x(1)%list(ipos_end)%compute%end @@ -907,7 +907,7 @@ if( PRESENT(xflags) )then if( BTEST(xflags,WEST) ) then !--- make sure no cross-domain in y-direction - if(domain%x(tile)%data%begin .LE. domain%x(tile)%global%begin .AND. & + if(domain%x(tile)%domain_data%begin .LE. domain%x(tile)%global%begin .AND. & domain%x(tile)%compute%begin > domain%x(tile)%global%begin ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when west is folded') @@ -919,7 +919,7 @@ endif if( BTEST(xflags,EAST) ) then !--- make sure no cross-domain in y-direction - if(domain%x(tile)%data%end .GE. domain%x(tile)%global%end .AND. & + if(domain%x(tile)%domain_data%end .GE. domain%x(tile)%global%end .AND. & domain%x(tile)%compute%end < domain%x(tile)%global%end ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when north is folded') @@ -933,7 +933,7 @@ if( PRESENT(yflags) )then if( BTEST(yflags,SOUTH) ) then !--- make sure no cross-domain in y-direction - if(domain%y(tile)%data%begin .LE. domain%y(tile)%global%begin .AND. & + if(domain%y(tile)%domain_data%begin .LE. domain%y(tile)%global%begin .AND. & domain%y(tile)%compute%begin > domain%y(tile)%global%begin ) then call mpp_error(FATAL, & 'MPP_DEFINE_DOMAINS: the domain could not be crossed when south is folded') @@ -3267,8 +3267,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at NORTH and CORNER need to be considered if( ( position == NORTH .OR. position == CORNER) ) then - if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold - !! is within domain + !fold is within domain + if( domain%y(tMe)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%domain_data%end+jshift )then dir = 3 !--- calculate the overlapping for sending if( domain%x(tMe)%pos .LT. (size(domain%x(tMe)%list(:))+1)/2 )then @@ -3367,7 +3367,7 @@ end subroutine check_message_size jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift !recv_e dir = 1 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then @@ -3402,8 +3402,8 @@ end subroutine check_message_size !recv_se dir = 2 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3419,7 +3419,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3441,8 +3441,8 @@ end subroutine check_message_size !recv_sw dir = 4 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg )then folded = .true. @@ -3462,7 +3462,7 @@ end subroutine check_message_size !recv_w dir = 5 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == NORTH .OR. position == CORNER ) .AND. ( jsd == je .or. jed == js ) ) then @@ -3506,8 +3506,8 @@ end subroutine check_message_size !recv_nw dir = 6 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg .AND. is.GE.ied )then !cyclic offset is = is-ioff; ie = ie-ioff @@ -3519,15 +3519,15 @@ end subroutine check_message_size !recv_n dir = 7 isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & is, ie, js, je, isd, ied, jsd, jed, dir, symmetry=domain%symmetry) !recv_ne dir = 8 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg .AND. ie.LT.isd )then ! cyclic offset is = is+ioff; ie = ie+ioff @@ -3539,8 +3539,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at NORTH and CORNER need to be considered if( ( position == NORTH .OR. position == CORNER) ) then - if( domain%y(tMe)%data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%data%end+jshift )then !fold - !! is within domain + !fold is within domain + if( domain%y(tMe)%domain_data%begin .LE. jsg .AND. jsg .LE. domain%y(tMe)%domain_data%end+jshift )then dir = 3 !--- calculating overlapping for receving on north if( domain%x(tMe)%pos .GE. size(domain%x(tMe)%list(:))/2 )then @@ -3907,8 +3907,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%compute%begin-whalo .LE. isg .AND. isg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 5 !--- calculate the overlapping for sending if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then @@ -4000,7 +4000,7 @@ end subroutine check_message_size jsc = domain%list(m)%y(1)%compute%begin; jec = domain%list(m)%y(1)%compute%end+jshift !recv_e dir = 1 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & @@ -4008,8 +4008,8 @@ end subroutine check_message_size !recv_se dir = 2 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed js = js-joff; je = je-joff @@ -4021,7 +4021,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then @@ -4065,8 +4065,8 @@ end subroutine check_message_size !recv_sw dir = 4 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg )then folded = .true. @@ -4087,7 +4087,7 @@ end subroutine check_message_size !recv_w dir = 5 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg )then @@ -4110,8 +4110,8 @@ end subroutine check_message_size !recv_nw dir = 6 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( isd.LT.isg) then folded = .true. @@ -4128,7 +4128,7 @@ end subroutine check_message_size dir = 7 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then !--- do nothing, this point will come from other pe @@ -4159,8 +4159,8 @@ end subroutine check_message_size !recv_ne dir = 8 - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset js = js+joff; je = je+joff @@ -4172,8 +4172,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. isg .AND. isg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 5 !--- calculating overlapping for receving on north if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then @@ -4536,8 +4536,8 @@ end subroutine check_message_size !--- Now calculate the overlapping for fold-edge. !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 1 !--- calculate the overlapping for sending if( domain%y(tMe)%pos .LT. (size(domain%y(tMe)%list(:))+1)/2 )then @@ -4617,7 +4617,7 @@ end subroutine check_message_size !recv_e dir = 1 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg )then @@ -4640,8 +4640,8 @@ end subroutine check_message_size !recv_se dir = 2 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg )then folded = .true. @@ -4663,7 +4663,7 @@ end subroutine check_message_size dir = 3 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then @@ -4706,8 +4706,8 @@ end subroutine check_message_size !recv_sw dir = 4 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%data%begin; jed = domain%y(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%domain_data%begin; jed = domain%y(tMe)%compute%begin-1 is=isc; ie=iec; js=jsc; je=jec if( jsd.LT.jsg .AND. js.GE.jed )then ! cyclic is assumed js = js-joff; je = je-joff @@ -4717,7 +4717,7 @@ end subroutine check_message_size !recv_w dir = 5 - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 jsd = domain%y(tMe)%compute%begin; jed = domain%y(tMe)%compute%end+jshift is=isc; ie=iec; js=jsc; je=jec call insert_update_overlap( overlap, domain%list(m)%pe, & @@ -4726,8 +4726,8 @@ end subroutine check_message_size !recv_nw dir = 6 folded = .false. - isd = domain%x(tMe)%data%begin; ied = domain%x(tMe)%compute%begin-1 - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%domain_data%begin; ied = domain%x(tMe)%compute%begin-1 + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( jed.GT.jeg .AND. je.LT.jsd )then ! cyclic offset js = js+joff; je = je+joff @@ -4739,7 +4739,7 @@ end subroutine check_message_size dir = 7 folded = .false. isd = domain%x(tMe)%compute%begin; ied = domain%x(tMe)%compute%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( (position == EAST .OR. position == CORNER ) .AND. ( isd == ie .or. ied == is ) ) then !--- do nothing, this point will come from other pe @@ -4771,8 +4771,8 @@ end subroutine check_message_size !recv_ne dir = 8 folded = .false. - isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%data%end+ishift - jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%data%end+jshift + isd = domain%x(tMe)%compute%end+1+ishift; ied = domain%x(tMe)%domain_data%end+ishift + jsd = domain%y(tMe)%compute%end+1+jshift; jed = domain%y(tMe)%domain_data%end+jshift is=isc; ie=iec; js=jsc; je=jec if( ied.GT.ieg) then folded = .true. @@ -4788,8 +4788,8 @@ end subroutine check_message_size !--- for folded-south-edge, only need to consider to_pe's south(3) direction !--- only position at EAST and CORNER need to be considered if( ( position == EAST .OR. position == CORNER) ) then - if( domain%x(tMe)%data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%data%end+ishift )then !fold - !! is within domain + !fold is within domain + if( domain%x(tMe)%domain_data%begin .LE. ieg .AND. ieg .LE. domain%x(tMe)%domain_data%end+ishift )then dir = 1 !--- calculating overlapping for receving on north if( domain%y(tMe)%pos .GE. size(domain%y(tMe)%list(:))/2 )then @@ -5702,32 +5702,32 @@ end subroutine check_message_size select case ( dir ) case ( 1 ) ! eastern halo if( align1Recv(n) .NE. EAST ) cycle - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end case ( 2 ) ! southeast halo - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 3 ) ! southern halo if( align1Recv(n) .NE. SOUTH ) cycle isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 4 ) ! southwest halo - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 - jsd2 = domain%y(tMe)%data%begin; jed2 = domain%y(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%domain_data%begin; jed2 = domain%y(tMe)%compute%begin-1 case ( 5 ) ! western halo if( align1Recv(n) .NE. WEST ) cycle - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 jsd2 = domain%y(tMe)%compute%begin; jed2 = domain%y(tMe)%compute%end case ( 6 ) ! northwest halo - isd2 = domain%x(tMe)%data%begin; ied2 = domain%x(tMe)%compute%begin-1 - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + isd2 = domain%x(tMe)%domain_data%begin; ied2 = domain%x(tMe)%compute%begin-1 + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end case ( 7 ) ! northern halo if( align1Recv(n) .NE. NORTH ) cycle isd2 = domain%x(tMe)%compute%begin; ied2 = domain%x(tMe)%compute%end - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end case ( 8 ) ! northeast halo - isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%data%end - jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%data%end + isd2 = domain%x(tMe)%compute%end+1; ied2 = domain%x(tMe)%domain_data%end + jsd2 = domain%y(tMe)%compute%end+1; jed2 = domain%y(tMe)%domain_data%end end select is = max(isd1,isd2); ie = min(ied1,ied2) js = max(jsd1,jsd2); je = min(jed1,jed2) @@ -7554,7 +7554,7 @@ ndivs = size(domain_in%list(:)) ! get the flag flag = 0 if(domain_in%cyclic) flag = flag + CYCLIC_GLOBAL_DOMAIN -if(domain_in%data%is_global) flag = flag + GLOBAL_DATA_DOMAIN +if(domain_in%domain_data%is_global) flag = flag + GLOBAL_DATA_DOMAIN call mpp_define_domains( global_indices, ndivs, domain_out, pelist = domain_in%list(:)%pe, & flags = flag, begin_halo = hbegin, end_halo = hend, extent = domain_in%list(:)%compute%size ) @@ -7594,9 +7594,9 @@ if(present(whalo) .or. present(ehalo) .or. present(shalo) .or. present(nhalo) ) ! get the flag xflag = 0; yflag = 0 if(domain_in%x(1)%cyclic) xflag = xflag + CYCLIC_GLOBAL_DOMAIN - if(domain_in%x(1)%data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN + if(domain_in%x(1)%domain_data%is_global) xflag = xflag + GLOBAL_DATA_DOMAIN if(domain_in%y(1)%cyclic) yflag = yflag + CYCLIC_GLOBAL_DOMAIN - if(domain_in%y(1)%data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN + if(domain_in%y(1)%domain_data%is_global) yflag = yflag + GLOBAL_DATA_DOMAIN call mpp_define_domains( global_indices, layout, domain_out, pelist = domain_in%list(:)%pe, & xflags = xflag, yflags = yflag, whalo = whalo, ehalo = ehalo, & @@ -7632,7 +7632,7 @@ subroutine mpp_define_null_domain1D(domain) type(domain1D), intent(inout) :: domain domain%global%begin = -1; domain%global%end = -1; domain%global%size = 0 -domain%data%begin = -1; domain%data%end = -1; domain%data%size = 0 +domain%domain_data%begin = -1; domain%domain_data%end = -1; domain%domain_data%size = 0 domain%compute%begin = -1; domain%compute%end = -1; domain%compute%size = 0 domain%pe = NULL_PE diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index 9cc31e26ff..f64dd2fc77 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -507,10 +507,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 1 domain%y%compute%end = -1 - domain%x%data %begin = -1 - domain%x%data %end = -1 - domain%y%data %begin = -1 - domain%y%data %end = -1 + domain%x%domain_data %begin = -1 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = -1 + domain%y%domain_data %end = -1 domain%x%global %begin = -1 domain%x%global %end = -1 domain%y%global %begin = -1 @@ -552,10 +552,10 @@ end subroutine init_nonblock_type domain%list(listpos)%y%compute%end = msg(5) domain%list(listpos)%tile_id(1) = msg(6) if(domain%x(1)%global%begin < 0) then - domain%x(1)%data %begin = msg(2) - domain%x(1)%data %end = msg(3) - domain%y(1)%data %begin = msg(4) - domain%y(1)%data %end = msg(5) + domain%x(1)%domain_data %begin = msg(2) + domain%x(1)%domain_data %end = msg(3) + domain%y(1)%domain_data %begin = msg(4) + domain%y(1)%domain_data %end = msg(5) domain%x(1)%global%begin = msg(2) domain%x(1)%global%end = msg(3) domain%y(1)%global%begin = msg(4) @@ -571,10 +571,10 @@ end subroutine init_nonblock_type endif domain%ntiles = msg(12) else - domain%x(1)%data %begin = msg(2) - msg(7) - domain%x(1)%data %end = msg(3) + msg(8) - domain%y(1)%data %begin = msg(4) - msg(9) - domain%y(1)%data %end = msg(5) + msg(10) + domain%x(1)%domain_data %begin = msg(2) - msg(7) + domain%x(1)%domain_data %end = msg(3) + msg(8) + domain%y(1)%domain_data %begin = msg(4) - msg(9) + domain%y(1)%domain_data %end = msg(5) + msg(10) domain%x(1)%global%begin = min(domain%x(1)%global%begin, msg(2)) domain%x(1)%global%end = max(domain%x(1)%global%end, msg(3)) domain%y(1)%global%begin = min(domain%y(1)%global%begin, msg(4)) @@ -633,10 +633,10 @@ end subroutine init_nonblock_type domain_out%x%compute%end = -1 domain_out%y%compute%begin = 1 domain_out%y%compute%end = -1 - domain_out%x%data %begin = -1 - domain_out%x%data %end = -1 - domain_out%y%data %begin = -1 - domain_out%y%data %end = -1 + domain_out%x%domain_data %begin = -1 + domain_out%x%domain_data %end = -1 + domain_out%y%domain_data %begin = -1 + domain_out%y%domain_data %end = -1 domain_out%x%global %begin = -1 domain_out%x%global %end = -1 domain_out%y%global %begin = -1 @@ -684,10 +684,10 @@ end subroutine init_nonblock_type domain_out%list(listpos)%y%compute%end = msg(5) domain_out%list(listpos)%tile_id(1) = msg(6) if(domain_out%x(1)%global%begin < 0) then - domain_out%x(1)%data %begin = msg(2) - domain_out%x(1)%data %end = msg(3) - domain_out%y(1)%data %begin = msg(4) - domain_out%y(1)%data %end = msg(5) + domain_out%x(1)%domain_data %begin = msg(2) + domain_out%x(1)%domain_data %end = msg(3) + domain_out%y(1)%domain_data %begin = msg(4) + domain_out%y(1)%domain_data %end = msg(5) domain_out%x(1)%global%begin = msg(2) domain_out%x(1)%global%end = msg(3) domain_out%y(1)%global%begin = msg(4) @@ -703,10 +703,10 @@ end subroutine init_nonblock_type endif domain_out%ntiles = msg(12) else - domain_out%x(1)%data %begin = msg(2) - msg(7) - domain_out%x(1)%data %end = msg(3) + msg(8) - domain_out%y(1)%data %begin = msg(4) - msg(9) - domain_out%y(1)%data %end = msg(5) + msg(10) + domain_out%x(1)%domain_data %begin = msg(2) - msg(7) + domain_out%x(1)%domain_data %end = msg(3) + msg(8) + domain_out%y(1)%domain_data %begin = msg(4) - msg(9) + domain_out%y(1)%domain_data %end = msg(5) + msg(10) domain_out%x(1)%global%begin = min(domain_out%x(1)%global%begin, msg(2)) domain_out%x(1)%global%end = max(domain_out%x(1)%global%end, msg(3)) domain_out%y(1)%global%begin = min(domain_out%y(1)%global%begin, msg(4)) @@ -771,10 +771,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 0 domain%y%compute%end = -1 - domain%x%data %begin = 0 - domain%x%data %end = -1 - domain%y%data %begin = 0 - domain%y%data %end = -1 + domain%x%domain_data %begin = 0 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = 0 + domain%y%domain_data %end = -1 domain%x%global %begin = 0 domain%x%global %end = -1 domain%y%global %begin = 0 @@ -888,10 +888,10 @@ end subroutine init_nonblock_type domain%x%compute%end = -1 domain%y%compute%begin = 0 domain%y%compute%end = -1 - domain%x%data %begin = 0 - domain%x%data %end = -1 - domain%y%data %begin = 0 - domain%y%data %end = -1 + domain%x%domain_data %begin = 0 + domain%x%domain_data %end = -1 + domain%y%domain_data %begin = 0 + domain%y%domain_data %end = -1 domain%x%global %begin = 0 domain%x%global %end = -1 domain%y%global %begin = 0 @@ -930,10 +930,10 @@ end subroutine init_nonblock_type if( .NOT.native .AND. msg(1).NE.NULL_PE .AND. tile_coarse==msg(16) )then domain%list(listpos)%pe = msg(1) if(domain%x(1)%compute%begin == 0) then - domain%x(1)%data %begin = msg(2) - msg(7) - domain%x(1)%data %end = msg(3) + msg(8) - domain%y(1)%data %begin = msg(4) - msg(9) - domain%y(1)%data %end = msg(5) + msg(10) + domain%x(1)%domain_data %begin = msg(2) - msg(7) + domain%x(1)%domain_data %end = msg(3) + msg(8) + domain%y(1)%domain_data %begin = msg(4) - msg(9) + domain%y(1)%domain_data %end = msg(5) + msg(10) domain%x(1)%global%begin = msg(12) domain%x(1)%global%end = msg(13) domain%y(1)%global%begin = msg(14) diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index 3d72df4a43..a8210895ed 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -63,8 +63,8 @@ mpp_domain1D_eq = ( a%compute%begin.EQ.b%compute%begin .AND. & a%compute%end .EQ.b%compute%end .AND. & - a%data%begin .EQ.b%data%begin .AND. & - a%data%end .EQ.b%data%end .AND. & + a%domain_data%begin .EQ.b%domain_data%begin .AND. & + a%domain_data%end .EQ.b%domain_data%end .AND. & a%global%begin .EQ.b%global%begin .AND. & a%global%end .EQ.b%global%end ) !compare pelists @@ -140,11 +140,11 @@ integer, intent(out), optional :: begin, end, size, max_size logical, intent(out), optional :: is_global - if( PRESENT(begin) )begin = domain%data%begin - if( PRESENT(end) )end = domain%data%end - if( PRESENT(size) )size = domain%data%size - if( PRESENT(max_size) )max_size = domain%data%max_size - if( PRESENT(is_global) )is_global = domain%data%is_global + if( PRESENT(begin) )begin = domain%domain_data%begin + if( PRESENT(end) )end = domain%domain_data%end + if( PRESENT(size) )size = domain%domain_data%size + if( PRESENT(max_size) )max_size = domain%domain_data%max_size + if( PRESENT(is_global) )is_global = domain%domain_data%is_global return end subroutine mpp_get_data_domain1D @@ -320,8 +320,8 @@ call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%compute) !< There is no data domain in domain%list - !call mpp_set_super_grid_indices(domain%list(i-1)%x(1)%data) - !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%data) + !call mpp_set_super_grid_indices(domain%list(i-1)%x(1)%domain_data) + !call mpp_set_super_grid_indices(domain%list(i-1)%y(1)%domain_data) enddo do i=1, size(domain%x(1)%list) @@ -370,10 +370,10 @@ integer, intent(in), optional :: begin, end, size logical, intent(in), optional :: is_global - if(present(begin)) domain%data%begin = begin - if(present(end)) domain%data%end = end - if(present(size)) domain%data%size = size - if(present(is_global)) domain%data%is_global = is_global + if(present(begin)) domain%domain_data%begin = begin + if(present(end)) domain%domain_data%end = end + if(present(size)) domain%domain_data%size = size + if(present(is_global)) domain%domain_data%is_global = is_global end subroutine mpp_set_data_domain1D @@ -1728,7 +1728,7 @@ end subroutine mpp_get_tile_compute_domains integer :: ending !< Ending bounds domain_out%compute = domain_in%compute - domain_out%data = domain_in%data + domain_out%domain_data = domain_in%domain_data domain_out%global = domain_in%global domain_out%memory = domain_in%memory domain_out%cyclic = domain_in%cyclic diff --git a/mpp/include/mpp_gather.fh b/mpp/include/mpp_gather.fh index 8ead643f3a..d51960de2f 100644 --- a/mpp/include/mpp_gather.fh +++ b/mpp/include/mpp_gather.fh @@ -109,12 +109,12 @@ subroutine MPP_GATHER_1DV_(sbuf, ssize, rbuf, rsize, pelist) end subroutine MPP_GATHER_1DV_ -subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & +subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, gather_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je), target, intent(in) :: array_seg - MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: data + MPP_TYPE_, dimension(:,:), contiguous, target, intent(inout) :: gather_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -123,7 +123,7 @@ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_roo arr3D(1:size(array_seg,1),1:size(array_seg,2),1:1) => array_seg if (is_root_pe) then - data3D(1:size(data,1),1:size(data,2),1:1) => data + data3D(1:size(gather_data,1),1:size(gather_data,2),1:1) => gather_data else data3D => null() endif @@ -135,12 +135,12 @@ subroutine MPP_GATHER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_roo end subroutine MPP_GATHER_PELIST_2D_ -subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & +subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, gather_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je,1:nk), intent(in) :: array_seg - MPP_TYPE_, dimension(:,:,:), intent(inout) :: data + MPP_TYPE_, dimension(:,:,:), intent(inout) :: gather_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -148,7 +148,7 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D - MPP_TYPE_, dimension(:,:,:), allocatable :: data + MPP_TYPE_, dimension(:,:,:), allocatable :: data3D_type endtype array3D type(array3d), dimension(:), allocatable :: temp @@ -200,7 +200,8 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" - if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & + if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(gather_data,1)) .OR. & + (maxval(gind(3:4,:)).gt.size(gather_data,2))) & call mpp_error(FATAL,"fms_io(mpp_gather_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else @@ -218,8 +219,8 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is j1 = gind(3,i) j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk - allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) - call mpp_recv(temp(i)%data(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) + allocate(temp(i)%data3D_type(i1:i2,j1:j2,1:nk)) + call mpp_recv(temp(i)%data3D_type(i1:i2,j1:j2,1:nk), msgsize, pelist(i), .FALSE., COMM_TAG_2) endif enddo call mpp_sync_self(check=EVENT_RECV) @@ -227,14 +228,14 @@ subroutine MPP_GATHER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is do i = 1, size(pelist) if (pelist(i).eq.root_pe) then ! data copy - no send to self - data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) + gather_data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) = array_seg(is:ie,js:je,1:nk) else i1 = gind(1,i) i2 = gind(2,i) j1 = gind(3,i) j2 = gind(4,i) - data(i1:i2,j1:j2,1:nk)=temp(i)%data(i1:i2,j1:j2,1:nk) - deallocate(temp(i)%data) + gather_data(i1:i2,j1:j2,1:nk)=temp(i)%data3D_type(i1:i2,j1:j2,1:nk) + deallocate(temp(i)%data3D_type) endif enddo deallocate(temp) diff --git a/mpp/include/mpp_global_field.fh b/mpp/include/mpp_global_field.fh index 3e5ff0d9db..1dd3d1121a 100644 --- a/mpp/include/mpp_global_field.fh +++ b/mpp/include/mpp_global_field.fh @@ -67,8 +67,8 @@ ! Also worth noting that many of the nD->3D conversion also assumes ! contiguity, so there many be other issues here. - isize = domain%x(tile)%data%size + ishift - jsize = domain%y(tile)%data%size + jshift + isize = domain%x(tile)%domain_data%size + ishift + jsize = domain%y(tile)%domain_data%size + jshift if ((size(local, 1) .eq. isize) .and. (size(local, 2) .eq. jsize) & .and. use_alltoallw) then call mpp_do_global_field_a2a(domain, local, global, tile, & diff --git a/mpp/include/mpp_global_reduce.fh b/mpp/include/mpp_global_reduce.fh index 060a052868..942f7876e1 100644 --- a/mpp/include/mpp_global_reduce.fh +++ b/mpp/include/mpp_global_reduce.fh @@ -63,8 +63,8 @@ joff = jsc else if( size(field,1).EQ.domain%x(1)%memory%size+ishift .AND. size(field,2).EQ.domain%y(1)%memory%size+jshift)then !field is on data domain - ioff = domain%x(1)%data%begin - joff = domain%y(1)%data%begin + ioff = domain%x(1)%domain_data%begin + joff = domain%y(1)%domain_data%begin else call mpp_error( FATAL, & & 'MPP_GLOBAL_REDUCE_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_global_sum.fh b/mpp/include/mpp_global_sum.fh index a230191952..1a487a4f4d 100644 --- a/mpp/include/mpp_global_sum.fh +++ b/mpp/include/mpp_global_sum.fh @@ -53,8 +53,8 @@ else if( size(field,1).EQ.domain%x(tile)%memory%size+ishift .AND. & & size(field,2).EQ.domain%y(tile)%memory%size+jshift )then !field is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_SUM_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_global_sum_ad.fh b/mpp/include/mpp_global_sum_ad.fh index 627b208f17..d1d9bb7699 100644 --- a/mpp/include/mpp_global_sum_ad.fh +++ b/mpp/include/mpp_global_sum_ad.fh @@ -57,8 +57,8 @@ subroutine MPP_GLOBAL_SUM_AD_( domain, field, gsum_, flags, position, tile_count else if( size(field,1).EQ.domain%x(tile)%memory%size+ishift .AND. & & size(field,2).EQ.domain%y(tile)%memory%size+jshift )then !field is on data domain - ioff = -domain%x(tile)%data%begin + 1 - joff = -domain%y(tile)%data%begin + 1 + ioff = -domain%x(tile)%domain_data%begin + 1 + joff = -domain%y(tile)%domain_data%begin + 1 else call mpp_error( FATAL, & & 'MPP_GLOBAL_SUM_: incoming field array must match either compute domain or data domain.' ) diff --git a/mpp/include/mpp_group_update.fh b/mpp/include/mpp_group_update.fh index 0f04c06c3b..45be7ea531 100644 --- a/mpp/include/mpp_group_update.fh +++ b/mpp/include/mpp_group_update.fh @@ -526,7 +526,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) if(domain%symmetry) shift = 1 if( nvector >0 .AND. BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags_v,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -534,7 +534,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) @@ -558,15 +558,15 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) do k = 1,ksize - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -577,7 +577,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin isd = domain%x(1)%compute%begin - group%whalo_v if( is.GT.isd )then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldy = group%addrs_y(l) @@ -592,7 +592,7 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) end if !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then ie = domain%x(1)%compute%end+group%ehalo_v is = is + 1 select case(gridtype) @@ -802,7 +802,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) if(domain%symmetry) shift = 1 if( nvector >0 .AND. BTEST(domain%fold,NORTH) .AND. (.NOT.BTEST(flags_v,SCALAR_BIT)) )then j = domain%y(1)%global%end+shift - if( domain%y(1)%data%begin.LE.j .AND. j.LE.domain%y(1)%data%end+shift )then !fold is within domain + if( domain%y(1)%domain_data%begin.LE.j .AND. j.LE.domain%y(1)%domain_data%end+shift )then !fold is within domain !poles set to 0: BGRID only if( gridtype.EQ.BGRID_NE )then midpoint = (domain%x(1)%global%begin+domain%x(1)%global%end-1+shift)/2 @@ -810,7 +810,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin; ie = domain%x(1)%global%end+shift if( .NOT. domain%symmetry ) is = is - 1 do i = is ,ie, midpoint - if( domain%x(1)%data%begin.LE.i .AND. i.LE. domain%x(1)%data%end+shift )then + if( domain%x(1)%domain_data%begin.LE.i .AND. i.LE. domain%x(1)%domain_data%end+shift )then do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) @@ -834,15 +834,15 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) else is = domain%x(1)%global%begin - 1 end if - if( is.GT.domain%x(1)%data%begin )then + if( is.GT.domain%x(1)%domain_data%begin )then - if( 2*is-domain%x(1)%data%begin.GT.domain%x(1)%data%end+shift ) & + if( 2*is-domain%x(1)%domain_data%begin.GT.domain%x(1)%domain_data%end+shift ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north BGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldx = group%addrs_x(l) ptr_fieldy = group%addrs_y(l) do k = 1,ksize - do i = domain%x(1)%data%begin,is-1 + do i = domain%x(1)%domain_data%begin,is-1 fieldx(i,j,k) = fieldx(2*is-i,j,k) fieldy(i,j,k) = fieldy(2*is-i,j,k) end do @@ -853,7 +853,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) is = domain%x(1)%global%begin isd = domain%x(1)%compute%begin - group%whalo_v if( is.GT.isd)then - if( 2*is-domain%x(1)%data%begin-1.GT.domain%x(1)%data%end ) & + if( 2*is-domain%x(1)%domain_data%begin-1.GT.domain%x(1)%domain_data%end ) & call mpp_error( FATAL, 'MPP_DO_UPDATE_V: folded-north CGRID_NE west edge ubound error.' ) do l=1,nvector ptr_fieldy = group%addrs_y(l) @@ -868,7 +868,7 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) end if !off east edge is = domain%x(1)%global%end - if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%data%end )then + if(domain%x(1)%cyclic .AND. is.LT.domain%x(1)%domain_data%end )then ie = domain%x(1)%compute%end+group%ehalo_v is = is + 1 select case(gridtype) diff --git a/mpp/include/mpp_scatter.fh b/mpp/include/mpp_scatter.fh index fce54f5a78..181796e87e 100644 --- a/mpp/include/mpp_scatter.fh +++ b/mpp/include/mpp_scatter.fh @@ -24,13 +24,13 @@ !! !> Scatter (ie - is) * (je - js) contiguous elements of array data from the designated root pe !! into contigous members of array segment in each pe that is included in the pelist argument. -subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_root_pe, & +subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, input_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je !< indices of segment array integer, dimension(:), intent(in) :: pelist ! array_seg if (is_root_pe) then - data3D(1:size(data,1),1:size(data,2),1:1) => data + data3D(1:size(input_data,1),1:size(input_data,2),1:1) => input_data else data3D => null() endif @@ -51,12 +51,12 @@ subroutine MPP_SCATTER_PELIST_2D_(is, ie, js, je, pelist, array_seg, data, is_ro end subroutine MPP_SCATTER_PELIST_2D_ -subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, is_root_pe, & +subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, input_data, is_root_pe, & ishift, jshift) integer, intent(in) :: is, ie, js, je, nk integer, dimension(:), intent(in) :: pelist MPP_TYPE_, dimension(is:ie,js:je,1:nk), intent(inout) :: array_seg - MPP_TYPE_, dimension(:,:,:), intent(in) :: data + MPP_TYPE_, dimension(:,:,:), intent(in) :: input_data logical, intent(in) :: is_root_pe integer, optional, intent(in) :: ishift, jshift @@ -64,7 +64,7 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i integer :: i1, i2, j1, j2, ioff, joff integer :: my_ind(4), gind(4,size(pelist)) type array3D - MPP_TYPE_, dimension(:,:,:), allocatable :: data + MPP_TYPE_, dimension(:,:,:), allocatable :: data3D_type endtype array3D type(array3d), dimension(size(pelist)) :: temp @@ -115,7 +115,8 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i gind(3,:)=gind(3,:)+joff gind(4,:)=gind(4,:)+joff ! check indices to make sure they are within the range of "data" - if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(data,1)) .OR. (maxval(gind(3:4,:)).gt.size(data,2))) & + if ((minval(gind).lt.1) .OR. (maxval(gind(1:2,:)).gt.size(input_data,1)) & + .OR. (maxval(gind(3:4,:)).gt.size(input_data,2))) & call mpp_error(FATAL,"fms_io(mpp_scatter_pelist): specified indices (with shift) are outside of the & &range of the receiving array") else @@ -134,18 +135,18 @@ subroutine MPP_SCATTER_PELIST_3D_(is, ie, js, je, nk, pelist, array_seg, data, i j2 = gind(4,i) msgsize = (i2-i1+1)*(j2-j1+1)*nk ! allocate and copy data into a contiguous memory space - allocate(temp(i)%data(i1:i2,j1:j2,1:nk)) - temp(i)%data(i1:i2,j1:j2,1:nk)=data(i1:i2,j1:j2,1:nk) - call mpp_send(temp(i)%data, msgsize, pelist(i), COMM_TAG_2) + allocate(temp(i)%data3D_type(i1:i2,j1:j2,1:nk)) + temp(i)%data3D_type(i1:i2,j1:j2,1:nk)=input_data(i1:i2,j1:j2,1:nk) + call mpp_send(temp(i)%data3D_type, msgsize, pelist(i), COMM_TAG_2) else ! data copy - no send to self - array_seg(is:ie,js:je,1:nk) = data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) + array_seg(is:ie,js:je,1:nk) = input_data(is+ioff:ie+ioff,js+joff:je+joff,1:nk) endif enddo call mpp_sync_self(check=EVENT_SEND) ! deallocate the temporary array used for the send do i = 1, size(pelist) - if (allocated(temp(i)%data)) deallocate(temp(i)%data) + if (allocated(temp(i)%data3D_type)) deallocate(temp(i)%data3D_type) enddo else ! non root_pe's recv data from root_pe diff --git a/mpp/include/mpp_transmit.inc b/mpp/include/mpp_transmit.inc index 24d0cc437f..aaa770cc06 100644 --- a/mpp/include/mpp_transmit.inc +++ b/mpp/include/mpp_transmit.inc @@ -305,79 +305,79 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine MPP_BROADCAST_SCALAR_( data, from_pe, pelist ) - MPP_TYPE_, intent(inout) :: data + subroutine MPP_BROADCAST_SCALAR_( broadcast_data, from_pe, pelist ) + MPP_TYPE_, intent(inout) :: broadcast_data integer, intent(in) :: from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(1) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call MPP_BROADCAST_( data1D, 1, from_pe, pelist ) return end subroutine MPP_BROADCAST_SCALAR_ - subroutine MPP_BROADCAST_2D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_2D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_2D_ - subroutine MPP_BROADCAST_3D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_3D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_3D_ - subroutine MPP_BROADCAST_4D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_4D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return end subroutine MPP_BROADCAST_4D_ - subroutine MPP_BROADCAST_5D_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_5D_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(:,:,:,:,:) + MPP_TYPE_, intent(inout) :: broadcast_data(:,:,:,:,:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) MPP_TYPE_ :: data1D(length) pointer( ptr, data1D ) - ptr = LOC(data) + ptr = LOC(broadcast_data) call mpp_broadcast( data1D, length, from_pe, pelist ) return diff --git a/mpp/include/mpp_transmit_mpi.fh b/mpp/include/mpp_transmit_mpi.fh index fa820300c1..e8eb68545f 100644 --- a/mpp/include/mpp_transmit_mpi.fh +++ b/mpp/include/mpp_transmit_mpi.fh @@ -164,11 +164,11 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> Broadcasts data to a pelist - subroutine MPP_BROADCAST_( data, length, from_pe, pelist ) + subroutine MPP_BROADCAST_( broadcast_data, length, from_pe, pelist ) !this call was originally bundled in with mpp_transmit, but that doesn't allow !broadcast to a subset of PEs. This version will, and mpp_transmit will remain !backward compatible. - MPP_TYPE_, intent(inout) :: data(*) + MPP_TYPE_, intent(inout) :: broadcast_data(*) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) integer :: n, i, from_rank, stdout_unit @@ -193,7 +193,7 @@ exit endif enddo - if( mpp_npes().GT.1 )call MPI_BCAST( data, length, MPI_TYPE_, from_rank, peset(n)%id, error ) + if( mpp_npes().GT.1 )call MPI_BCAST( broadcast_data, length, MPI_TYPE_, from_rank, peset(n)%id, error ) if( debug .and. (current_clock.NE.0) )call increment_current_clock( EVENT_BROADCAST, length*MPP_TYPE_BYTELEN_ ) return end subroutine MPP_BROADCAST_ diff --git a/mpp/include/mpp_unstruct_pass_data.fh b/mpp/include/mpp_unstruct_pass_data.fh index 656a7789d3..9dddff0f3d 100644 --- a/mpp/include/mpp_unstruct_pass_data.fh +++ b/mpp/include/mpp_unstruct_pass_data.fh @@ -50,10 +50,10 @@ SUBROUTINE mpp_pass_SG_to_UG_3D_(UG_domain, field_SG, field_UG) size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%compute%size) then ioff = 1 - UG_domain%SG_domain%x(1)%compute%begin joff = 1 - UG_domain%SG_domain%y(1)%compute%begin - else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%data%size .AND. & - size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%data%size) then - ioff = 1 - UG_domain%SG_domain%x(1)%data%begin - joff = 1 - UG_domain%SG_domain%y(1)%data%begin + else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%domain_data%size .AND. & + size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%domain_data%size) then + ioff = 1 - UG_domain%SG_domain%x(1)%domain_data%begin + joff = 1 - UG_domain%SG_domain%y(1)%domain_data%begin else call mpp_error( FATAL, 'mpp_pass_SG_to_UG_3D_: field_SG must match either compute domain or data domain.' ) endif @@ -154,10 +154,10 @@ SUBROUTINE mpp_pass_UG_to_SG_3D_(UG_domain, field_UG, field_SG) size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%compute%size) then ioff = 1 - UG_domain%SG_domain%x(1)%compute%begin joff = 1 - UG_domain%SG_domain%y(1)%compute%begin - else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%data%size .AND. & - size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%data%size) then - ioff = 1 - UG_domain%SG_domain%x(1)%data%begin - joff = 1 - UG_domain%SG_domain%y(1)%data%begin + else if(size(field_SG,1) .EQ. UG_domain%SG_domain%x(1)%domain_data%size .AND. & + size(field_SG,2) .EQ. UG_domain%SG_domain%y(1)%domain_data%size) then + ioff = 1 - UG_domain%SG_domain%x(1)%domain_data%begin + joff = 1 - UG_domain%SG_domain%y(1)%domain_data%begin else call mpp_error( FATAL, 'mpp_pass_UG_to_SG_3D_: field_SG must match either compute domain or data domain.' ) endif diff --git a/mpp/include/mpp_update_domains2D_nonblock.fh b/mpp/include/mpp_update_domains2D_nonblock.fh index fc8c9df306..7549abb533 100644 --- a/mpp/include/mpp_update_domains2D_nonblock.fh +++ b/mpp/include/mpp_update_domains2D_nonblock.fh @@ -45,7 +45,7 @@ function MPP_START_UPDATE_DOMAINS_3D_( field, domain, flags, position, & whalo, ehalo, shalo, nhalo, name, tile_count, update_id, complete ) type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:) + MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. @@ -316,7 +316,7 @@ subroutine MPP_COMPLETE_UPDATE_DOMAINS_3D_( id_update, field, domain, flags, pos whalo, ehalo, shalo, nhalo, name, tile_count, complete ) integer, intent(in) :: id_update type(domain2D), intent(inout) :: domain - MPP_TYPE_, intent(inout) :: field(domain%x(1)%data%begin:,domain%y(1)%data%begin:,:) + MPP_TYPE_, intent(inout) :: field(domain%x(1)%domain_data%begin:,domain%y(1)%domain_data%begin:,:) integer, intent(in), optional :: flags integer, intent(in), optional :: position integer, intent(in), optional :: whalo, ehalo, shalo, nhalo ! specify halo region to be updated. diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index 02db652bc3..e46f424e38 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -628,7 +628,7 @@ module mpp_domains_mod type :: domain1D private type(domain_axis_spec) :: compute !< index limits for compute domain - type(domain_axis_spec) :: data !< index limits for data domain + type(domain_axis_spec) :: domain_data !< index limits for data domain type(domain_axis_spec) :: global !< index limits for global domain type(domain_axis_spec) :: memory !< index limits for memory domain logical :: cyclic !< true if domain is cyclic diff --git a/test_fms/mpp/fill_halo.F90 b/test_fms/mpp/fill_halo.F90 index bb8996ce38..63013ddbf8 100644 --- a/test_fms/mpp/fill_halo.F90 +++ b/test_fms/mpp/fill_halo.F90 @@ -90,285 +90,285 @@ module fill_halo contains !> fill the halo region of a 64-bit real array with zeros - subroutine fill_halo_zero_r8(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_r8(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - real(kind=r8_kind), dimension(isd:,jsd:,:), intent(inout) :: data + real(kind=r8_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_r8 !> fill the halo region of a 32-bit real array with zeros - subroutine fill_halo_zero_r4(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_r4(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - real(kind=r4_kind), dimension(isd:,jsd:,:), intent(inout) :: data + real(kind=r4_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_r4 !> fill the halo region of a 64-bit integer array with zeros - subroutine fill_halo_zero_i8(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_i8(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - integer(kind=i8_kind), dimension(isd:,jsd:,:), intent(inout) :: data + integer(kind=i8_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_i8 !> fill the halo region of a 32-bit integer array with zeros - subroutine fill_halo_zero_i4(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & + subroutine fill_halo_zero_i4(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, & & jsd, jed) - integer(kind=i4_kind), dimension(isd:,jsd:,:), intent(inout) :: data + integer(kind=i4_kind), dimension(isd:,jsd:,:), intent(inout) :: halo_data integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero_i4 !> fill the halo region of 64-bit array on a regular grid - subroutine fill_regular_refinement_halo_r8( data, data_all, ni, nj, tm, te, tse, ts, & + subroutine fill_regular_refinement_halo_r8( halo_data, data_all, ni, nj, tm, te, tse, ts, & tsw, tw, tnw, tn, tne, ioff, joff ) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_r8 !> fill the halo region of 32-bit array on a regular grid - subroutine fill_regular_refinement_halo_r4( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & + subroutine fill_regular_refinement_halo_r4( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & & ioff, joff ) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_r4 !> fill the halo region of 64-bit integer array on a regular grid - subroutine fill_regular_refinement_halo_i8( data, data_all, ni, nj, tm, te, tse, ts, tsw, & + subroutine fill_regular_refinement_halo_i8( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, & tw, tnw, tn, tne, ioff, joff ) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_i8 !> fill the halo region of 32-bit integer array on a regular grid - subroutine fill_regular_refinement_halo_i4( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & + subroutine fill_regular_refinement_halo_i4( halo_data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, & & ioff, joff ) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo_i4 ! Fill the halo points of a 64-bit real array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_r8(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_r8(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_r8 !> Fill the halo points of a 32-bit real array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_r4(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_r4(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real(kind=r4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_r4 ! Fill the halo points of a 64-bit integer array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_i8(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_i8(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i8_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_i8 !> Fill the halo points of a 64-bit integer array on the regular mosaic grid - subroutine fill_regular_mosaic_halo_i4(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo_i4(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer(kind=i4_kind), dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo_i4 !> Fill the halo region of a 64-bit array real on a domain with a folded north edge - subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -378,18 +378,19 @@ subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded north edge - subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -399,19 +400,20 @@ subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded north edge - subroutine fill_folded_north_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -421,18 +423,19 @@ subroutine fill_folded_north_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded north edge - subroutine fill_folded_north_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -442,19 +445,20 @@ subroutine fill_folded_north_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift,1:ny+jshift,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift,1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1,nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2,nyp+1:nyp+nhalo,:) = sign*halo_data(nx+ishift:1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1,nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded south edge - subroutine fill_folded_south_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -464,19 +468,19 @@ subroutine fill_folded_south_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded south edge - subroutine fill_folded_south_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -486,19 +490,19 @@ subroutine fill_folded_south_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_r4 !> Fill the halo region of a 64-bit intger array on a domain with a folded south edge - subroutine fill_folded_south_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -508,19 +512,19 @@ subroutine fill_folded_south_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded south edge - subroutine fill_folded_south_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -530,19 +534,19 @@ subroutine fill_folded_south_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0,1:nyp,:) = data(nx-whalo+1:nx,1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift,1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east + halo_data(1-whalo:0,1:nyp,:) = halo_data(nx-whalo+1:nx,1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift,1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1,1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:m1,1-shalo:0,:) = sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2,1-shalo:0,:) = sign*data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2,1-shalo:0,:) = sign*halo_data(nxp:1:-1,shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1,shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded west edge - subroutine fill_folded_west_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -552,18 +556,18 @@ subroutine fill_folded_west_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded west edge - subroutine fill_folded_west_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -573,18 +577,18 @@ subroutine fill_folded_west_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded west edge - subroutine fill_folded_west_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -594,18 +598,18 @@ subroutine fill_folded_west_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded west edge - subroutine fill_folded_west_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -615,18 +619,18 @@ subroutine fill_folded_west_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0,:) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo,:) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0,:) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo,:) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(1-whalo:0, 1-shalo:m1,:) = sign*data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2,:) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1-whalo:0, 1-shalo:m1,:) = sign*halo_data(whalo+ishift:1+ishift:-1,shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2,:) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo_i4 !> Fill the halo region of a 64-bit real array on a domain with a folded east edge - subroutine fill_folded_east_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -636,19 +640,20 @@ subroutine fill_folded_east_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_r8 !> Fill the halo region of a 32-bit real array on a domain with a folded east edge - subroutine fill_folded_east_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(kind=r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -658,19 +663,20 @@ subroutine fill_folded_east_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_r4 !> Fill the halo region of a 64-bit integer array on a domain with a folded east edge - subroutine fill_folded_east_halo_i8(data, ioff, joff, ishift, jshift, sign) - integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_i8(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -680,19 +686,20 @@ subroutine fill_folded_east_halo_i8(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_i8 !> Fill the halo region of a 32-bit integer array on a domain with a folded east edge - subroutine fill_folded_east_halo_i4(data, ioff, joff, ishift, jshift, sign) - integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo_i4(halo_data, ioff, joff, ishift, jshift, sign) + integer(kind=i4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in) :: ioff, joff, ishift, jshift, sign ! local integer :: nxp, nyp, m1, m2 @@ -702,13 +709,14 @@ subroutine fill_folded_east_halo_i4(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north if(m1 .GE. 1-shalo) & - data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) + halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo_i4 diff --git a/test_fms/mpp/test_domains_utility_mod.F90 b/test_fms/mpp/test_domains_utility_mod.F90 index f88054b9f5..65926016ed 100644 --- a/test_fms/mpp/test_domains_utility_mod.F90 +++ b/test_fms/mpp/test_domains_utility_mod.F90 @@ -38,11 +38,11 @@ module test_domains_utility_mod contains -subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & +subroutine fill_coarse_data_r8(coarse_data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & ishift, jshift, x_add, y_add, sign1, sign2, x_cyclic, y_cyclic, ieg, jeg) integer, intent(in) :: rotate, is_c, ie_c, js_c, je_c, nz, isd, jsd, iadd, jadd, nx, ny, ishift, jshift integer, intent(in) :: sign1, sign2 - real(kind=r8_kind), intent(inout) :: data(isd:, jsd:, :) + real(kind=r8_kind), intent(inout) :: coarse_data(isd:, jsd:, :) real(kind=r8_kind), intent(in) :: x_add, y_add logical, intent(in) :: x_cyclic, y_cyclic integer, intent(in) :: ieg, jeg @@ -54,7 +54,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = dble(i+iadd)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i+iadd)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add enddo enddo enddo @@ -63,7 +63,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign1*( dble(nx-j+1+iadd+jshift)*1.d+6 + dble(i+jadd)*1.d+3 + dble(k) + y_add) + coarse_data(i,j,k) = sign1*( dble(nx-j+1+iadd+jshift)*1.d+6 + dble(i+jadd)*1.d+3 + dble(k) + y_add) enddo enddo enddo @@ -72,7 +72,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign2*( dble(j+iadd)*1.d+6 + dble(ny-i+1+jadd+ishift)*1.d+3 + dble(k) + y_add) + coarse_data(i,j,k) = sign2*( dble(j+iadd)*1.d+6 + dble(ny-i+1+jadd+ishift)*1.d+3 + dble(k) + y_add) enddo enddo enddo @@ -86,7 +86,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, i = ie_c+ishift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = dble(i)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i)*1.d+6 + dble(j+jadd)*1.d+3 + dble(k) + x_add enddo enddo endif @@ -98,7 +98,7 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, j = je_c+jshift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = dble(i+iadd)*1.d+6 + j*1.d+3 + dble(k) + x_add + coarse_data(i,j,k) = dble(i+iadd)*1.d+6 + j*1.d+3 + dble(k) + x_add enddo enddo endif @@ -107,11 +107,11 @@ subroutine fill_coarse_data_r8(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, end subroutine fill_coarse_data_r8 -subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & +subroutine fill_coarse_data_r4(coarse_data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, nz, isd, jsd, nx, ny, & ishift, jshift, x_add, y_add, sign1, sign2, x_cyclic, y_cyclic, ieg, jeg) integer, intent(in) :: rotate, is_c, ie_c, js_c, je_c, nz, isd, jsd, iadd, jadd, nx, ny, ishift, jshift integer, intent(in) :: sign1, sign2 - real(kind=r4_kind), intent(inout) :: data(isd:, jsd:, :) + real(kind=r4_kind), intent(inout) :: coarse_data(isd:, jsd:, :) real(kind=r4_kind), intent(in) :: x_add, y_add logical, intent(in) :: x_cyclic, y_cyclic integer, intent(in) :: ieg, jeg @@ -123,7 +123,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = (i+iadd)*1.e+6 + (j+jadd)*1.e+3 + k + x_add + coarse_data(i,j,k) = (i+iadd)*1.e+6 + (j+jadd)*1.e+3 + k + x_add enddo enddo enddo @@ -132,7 +132,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign1*((nx-j+1+iadd+jshift)*1.e+6 + (i+jadd)*1.e+3 + k + y_add) + coarse_data(i,j,k) = sign1*((nx-j+1+iadd+jshift)*1.e+6 + (i+jadd)*1.e+3 + k + y_add) enddo enddo enddo @@ -141,7 +141,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, do k = 1, nz do j = js_c, je_c+jshift do i = is_c, ie_c+ishift - data(i,j,k) = sign2*((j+iadd)*1.e+6 + (ny-i+1+jadd+ishift)*1.e+3 + k + y_add) + coarse_data(i,j,k) = sign2*((j+iadd)*1.e+6 + (ny-i+1+jadd+ishift)*1.e+3 + k + y_add) enddo enddo enddo @@ -155,7 +155,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, i = ie_c+ishift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = i*1.e+6 + (j+jadd)*1.e+3 + k + x_add + coarse_data(i,j,k) = i*1.e+6 + (j+jadd)*1.e+3 + k + x_add enddo enddo endif @@ -167,7 +167,7 @@ subroutine fill_coarse_data_r4(data, rotate, iadd, jadd, is_c, ie_c, js_c, je_c, j = je_c+jshift do k = 1, nz do j = js_c, je_c+jshift - data(i,j,k) = (i+iadd)*1.e+6 + j*1.e+3 + k + x_add + coarse_data(i,j,k) = (i+iadd)*1.e+6 + j*1.e+3 + k + x_add enddo enddo endif diff --git a/test_fms/mpp/test_mpp_domains.F90 b/test_fms/mpp/test_mpp_domains.F90 index 3ca557788f..ffd9a45d26 100644 --- a/test_fms/mpp/test_mpp_domains.F90 +++ b/test_fms/mpp/test_mpp_domains.F90 @@ -3678,63 +3678,64 @@ subroutine test_unstruct_update( type ) end subroutine test_unstruct_update !################################################################################# - subroutine fill_halo_zero(data, whalo, ehalo, shalo, nhalo, xshift, yshift, isc, iec, jsc, jec, isd, ied, jsd, jed) + subroutine fill_halo_zero(halo_data, whalo, ehalo, shalo, nhalo, xshift, yshift, & + isc, iec, jsc, jec, isd, ied, jsd, jed) integer, intent(in) :: isc, iec, jsc, jec, isd, ied, jsd, jed integer, intent(in) :: whalo, ehalo, shalo, nhalo, xshift, yshift - real, dimension(isd:,jsd:,:), intent(inout) :: data + real, dimension(isd:,jsd:,:), intent(inout) :: halo_data if(whalo >=0) then - data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 - data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 + halo_data(iec+ehalo+1+xshift:ied+xshift,jsd:jed+yshift,:) = 0 + halo_data(isd:isc-whalo-1,jsd:jed+yshift,:) = 0 else - data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 - data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(iec+1+xshift:iec-ehalo+xshift,jsc+shalo:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:isc-1,jsc+shalo:jec-nhalo+yshift,:) = 0 end if if(shalo>=0) then - data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 - data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 + halo_data(isd:ied+xshift, jec+nhalo+1+yshift:jed+yshift,:) = 0 + halo_data(isd:ied+xshift, jsd:jsc-shalo-1,:) = 0 else - data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 - data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jec+1+yshift:jec-nhalo+yshift,:) = 0 + halo_data(isc+whalo:iec-ehalo+xshift,jsc+shalo:jsc-1,:) = 0 end if end subroutine fill_halo_zero !############################################################################## ! this routine fill the halo points for the regular mosaic. - subroutine fill_regular_mosaic_halo(data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_mosaic_halo(halo_data, data_all, te, tse, ts, tsw, tw, tnw, tn, tne) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: te, tse, ts, tsw, tw, tnw, tn, tne - data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east - data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south - data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west - data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north - data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast - data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest - data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast - data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest + halo_data(nx+1:nx+ehalo, 1:ny, :) = data_all(1:ehalo, 1:ny, :, te) ! east + halo_data(1:nx, 1-shalo:0, :) = data_all(1:nx, ny-shalo+1:ny, :, ts) ! south + halo_data(1-whalo:0, 1:ny, :) = data_all(nx-whalo+1:nx, 1:ny, :, tw) ! west + halo_data(1:nx, ny+1:ny+nhalo, :) = data_all(1:nx, 1:nhalo, :, tn) ! north + halo_data(nx+1:nx+ehalo, 1-shalo:0, :) = data_all(1:ehalo, ny-shalo+1:ny, :,tse) ! southeast + halo_data(1-whalo:0, 1-shalo:0, :) = data_all(nx-whalo+1:nx, ny-shalo+1:ny, :,tsw) ! southwest + halo_data(nx+1:nx+ehalo, ny+1:ny+nhalo, :) = data_all(1:ehalo, 1:nhalo, :,tnw) ! northeast + halo_data(1-whalo:0, ny+1:ny+nhalo, :) = data_all(nx-whalo+1:nx, 1:nhalo, :,tne) ! northwest end subroutine fill_regular_mosaic_halo - subroutine fill_folded_north_halo(data, ioff, joff, ishift, jshift, sign) - class(*), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo(halo_data, ioff, joff, ishift, jshift, sign) + class(*), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign - select type(data) + select type(halo_data) type is (real(r4_kind)) - call fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) + call fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) type is (real(r8_kind)) - call fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) + call fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) end select end subroutine !################################################################################ - subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) - real(r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r4(halo_data, ioff, joff, ishift, jshift, sign) + real(r4_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3743,17 +3744,19 @@ subroutine fill_folded_north_halo_r4(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:ny+jshift,:) ! east - if(m1 .GE. 1-whalo) data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1, & + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:ny+jshift,:) ! east + if(m1 .GE. 1-whalo) halo_data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1, & & nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r4 ! r8 version needed for mixed mode - subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) - real(r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_north_halo_r8(halo_data, ioff, joff, ishift, jshift, sign) + real(r8_kind), dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3762,18 +3765,20 @@ subroutine fill_folded_north_halo_r8(data, ioff, joff, ishift, jshift, sign) m1 = ishift - ioff m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:ny+jshift,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:ny+jshift,:) ! east + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:ny+jshift,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:ny+jshift,:) ! east if(m1 .GE. 1-whalo) & - data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = sign*data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) - data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = sign*data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(1-whalo:m1, nyp+1:nyp+nhalo,:) = sign*halo_data(whalo+m2:1+ishift:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(m1+1:nx+m2, nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx+ishift:1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) + halo_data(nx+m2+1:nxp+ehalo,nyp+1:nyp+nhalo,:) = & + sign*halo_data(nx:nx-ehalo+m1+1:-1, nyp-joff:nyp-nhalo-joff+1:-1,:) end subroutine fill_folded_north_halo_r8 !################################################################################ - subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_south_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3783,17 +3788,18 @@ subroutine fill_folded_south_halo(data, ioff, joff, ishift, jshift, sign) m2 = 2*ishift - ioff - data(1-whalo:0, 1:nyp,:) = data(nx-whalo+1:nx, 1:nyp,:) ! west - data(nx+1:nx+ehalo+ishift, 1:nyp,:) = data(1:ehalo+ishift, 1:nyp,:) ! east - if(m1 .GE. 1-whalo)data(1-whalo:m1, 1-shalo:0,:) = sign*data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) - data(m1+1:nx+m2, 1-shalo:0,:) = sign*data(nxp:1:-1, shalo+jshift:1+jshift:-1,:) - data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*data(nx:nx-ehalo+m1+1:-1, shalo+jshift:1+jshift:-1,:) + halo_data(1-whalo:0, 1:nyp,:) = halo_data(nx-whalo+1:nx, 1:nyp,:) ! west + halo_data(nx+1:nx+ehalo+ishift, 1:nyp,:) = halo_data(1:ehalo+ishift, 1:nyp,:) ! east + if(m1 .GE. 1-whalo)halo_data(1-whalo:m1, 1-shalo:0,:) = & + sign*halo_data(whalo+m2:1+ishift:-1, shalo+jshift:1+jshift:-1,:) + halo_data(m1+1:nx+m2, 1-shalo:0,:) = sign*halo_data(nxp:1:-1, shalo+jshift:1+jshift:-1,:) + halo_data(nx+m2+1:nxp+ehalo,1-shalo:0,:) = sign*halo_data(nx:nx-ehalo+m1+1:-1, shalo+jshift:1+jshift:-1,:) end subroutine fill_folded_south_halo !################################################################################ - subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_west_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3802,17 +3808,18 @@ subroutine fill_folded_west_halo(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north - if(m1 .GE. 1-shalo) data(1-whalo:0, 1-shalo:m1, :) = sign*data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:) - data(1-whalo:0, m1+1:ny+m2, :) = sign*data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) - data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north + if(m1 .GE. 1-shalo) halo_data(1-whalo:0, 1-shalo:m1, :) = & + sign*halo_data(whalo+ishift:1+ishift:-1, shalo+m2:1+jshift:-1,:) + halo_data(1-whalo:0, m1+1:ny+m2, :) = sign*halo_data(whalo+ishift:1+ishift:-1, nyp:1:-1, :) + halo_data(1-whalo:0, ny+m2+1:nyp+nhalo,:) = sign*halo_data(whalo+ishift:1+ishift:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_west_halo !################################################################################ - subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_folded_east_halo(halo_data, ioff, joff, ishift, jshift, sign) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data integer, intent(in ) :: ioff, joff, ishift, jshift, sign integer :: nxp, nyp, m1, m2 @@ -3821,12 +3828,13 @@ subroutine fill_folded_east_halo(data, ioff, joff, ishift, jshift, sign) m1 = jshift - joff m2 = 2*jshift - joff - data(1:nxp, 1-shalo:0, :) = data(1:nxp, ny-shalo+1:ny, :) ! south - data(1:nxp, ny+1:nyp+nhalo, :) = data(1:nxp, 1:nhalo+jshift,:) ! north - if(m1 .GE. 1-shalo) data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, & + halo_data(1:nxp, 1-shalo:0, :) = halo_data(1:nxp, ny-shalo+1:ny, :) ! south + halo_data(1:nxp, ny+1:nyp+nhalo, :) = halo_data(1:nxp, 1:nhalo+jshift,:) ! north + if(m1 .GE. 1-shalo) halo_data(nxp+1:nxp+ehalo, 1-shalo:m1, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, & & shalo+m2:1+jshift:-1,:) - data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) - data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = sign*data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) + halo_data(nxp+1:nxp+ehalo, m1+1:ny+m2, :) = sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, nyp:1:-1, :) + halo_data(nxp+1:nxp+ehalo, ny+m2+1:nyp+nhalo,:) = & + sign*halo_data(nxp-ioff:nxp-ehalo-ioff+1:-1, ny:ny-nhalo+m1+1:-1,:) end subroutine fill_folded_east_halo @@ -4081,8 +4089,8 @@ end subroutine fill_cubic_grid_bound !############################################################################## ! this routine fill the halo points for the cubic grid. ioff and joff is used to distinguish ! T, C, E, or N-cell - subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, sign1, sign2) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_cubic_grid_halo(halo_data, data1_all, data2_all, tile, ioff, joff, sign1, sign2) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data1_all, data2_all integer, intent(in) :: tile, ioff, joff, sign1, sign2 integer :: lw, le, ls, ln @@ -4092,26 +4100,26 @@ subroutine fill_cubic_grid_halo(data, data1_all, data2_all, tile, ioff, joff, si if(le > 6 ) le = le - 6 if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 - data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw) ! west + halo_data(1-whalo:0, 1:ny+joff, :) = data1_all(nx-whalo+1:nx, 1:ny+joff, :, lw) ! west do i = 1, ehalo - data(nx+i+ioff, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le) ! east + halo_data(nx+i+ioff, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, i+ioff, :, le) ! east end do do i = 1, shalo - data(1:nx+ioff, 1-i, :) = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls) ! south + halo_data(1:nx+ioff, 1-i, :) = sign2*data2_all(nx-i+1, ny+ioff:1:-1, :, ls) ! south end do - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln) ! north + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff, :) = data1_all(1:nx+ioff, 1+joff:nhalo+joff, :, ln) ! north else ! tile 1, 3, 5 lw = tile - 2; le = tile + 1; ls = tile - 1; ln = tile + 2 if(lw < 1 ) lw = lw + 6 if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 do i = 1, whalo - data(1-i, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw) ! west + halo_data(1-i, 1:ny+joff, :) = sign1*data2_all(nx+joff:1:-1, ny-i+1, :, lw) ! west end do - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le) ! east - data(1:nx+ioff, 1-shalo:0, :) = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls) ! south + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff, :) = data1_all(1+ioff:ehalo+ioff, 1:ny+joff, :, le) ! east + halo_data(1:nx+ioff, 1-shalo:0, :) = data1_all(1:nx+ioff, ny-shalo+1:ny, :, ls) ! south do i = 1, nhalo - data(1:nx+ioff, ny+i+joff, :) = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln) ! north + halo_data(1:nx+ioff, ny+i+joff, :) = sign2*data2_all(i+joff, ny+ioff:1:-1, :, ln) ! north end do end if @@ -4456,8 +4464,8 @@ subroutine test_nonuniform_mosaic( type ) end subroutine test_nonuniform_mosaic - subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_five_tile_halo(halo_data, data_all, tile, ioff, joff) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, intent(in) :: tile, ioff, joff integer :: nxm, nym @@ -4466,57 +4474,58 @@ subroutine fill_five_tile_halo(data, data_all, tile, ioff, joff) select case(tile) case(1) - data(nxm+1+ioff:nxm+ehalo+ioff, 1:ny,:) = data_all(1+ioff:ehalo+ioff, 1:ny,:,2) ! east - data(nxm+1+ioff:nxm+ehalo+ioff, ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,4) ! east - data(1-whalo:0, 1:ny,:) = data_all(nx-whalo+1:nx, 1:ny,:,3) ! west - data(1-whalo:0, ny+1:nym+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,5) ! west - data(1:nxm+ioff, 1-shalo:0,:) = data_all(1:nxm+ioff, nym-shalo+1:nym,:,1) ! south - data(1:nxm+ioff, nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff, 1+joff:nhalo+joff,:,1) ! north - data(nxm+1+ioff:nxm+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,4) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,5) ! southwest - data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = & + halo_data(nxm+1+ioff:nxm+ehalo+ioff, 1:ny,:) = data_all(1+ioff:ehalo+ioff, 1:ny,:,2) ! east + halo_data(nxm+1+ioff:nxm+ehalo+ioff, ny+1:nym+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,4) ! east + halo_data(1-whalo:0, 1:ny,:) = data_all(nx-whalo+1:nx, 1:ny,:,3) ! west + halo_data(1-whalo:0, ny+1:nym+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,5) ! west + halo_data(1:nxm+ioff, 1-shalo:0,:) = data_all(1:nxm+ioff, nym-shalo+1:nym,:,1) ! south + halo_data(1:nxm+ioff, nym+1+joff:nym+nhalo+joff,:) = data_all(1:nxm+ioff, 1+joff:nhalo+joff,:,1) ! north + halo_data(nxm+1+ioff:nxm+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,4) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,5) ! southwest + halo_data(nxm+1+ioff:nxm+ehalo+ioff,nym+1+joff:nym+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,2) ! northeast - data(1-whalo:0, nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,3) ! northwest + halo_data(1-whalo:0, nym+1+joff:nym+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,3) ! northwest case(2) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,3) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, 1:ny+joff,:,1) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,4) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,4) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,5) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, nym-shalo+1:nym,:,1) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & - & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,5) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, ny+1+joff:ny+nhalo+joff,:,1) ! northwest + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,3) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, 1:ny+joff,:,1) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,4) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,4) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,5) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, nym-shalo+1:nym,:,1) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff,:,5) ! northeast + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = & + data_all(nxm-whalo+1:nxm, ny+1+joff:ny+nhalo+joff,:,1) ! northwest case(3) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,1) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,2) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,5) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,5) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, nym-shalo+1:nym,:,1) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,4) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & - & data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,4) ! northwest + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,1) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,2) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,5) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,5) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, nym-shalo+1:nym,:,1) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,4) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + & data_all(1+ioff:ehalo+ioff,ny+1+joff:ny+nhalo+joff,:,1) ! northeast + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,4) ! northwest case(4) - data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,5) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, ny+1:2*ny+joff,:,1) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,2) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,2) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,3) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, ny-shalo+1:ny,:,1) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + halo_data(nx+1+ioff:nx+ehalo+ioff, 1:ny+joff,:) = data_all(1+ioff:ehalo+ioff, 1:ny+joff,:,5) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nxm-whalo+1:nxm, ny+1:2*ny+joff,:,1) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,2) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,2) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,3) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nxm-whalo+1:nxm, ny-shalo+1:ny,:,1) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,3) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, 1+joff:nhalo+joff,:,1) ! northwest + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nxm-whalo+1:nxm, 1+joff:nhalo+joff,:,1) ! northwest case(5) - data(nx+1+ioff:nx+ehalo+ioff, 1: ny+joff,:) = data_all(1+ioff:ehalo+ioff, ny+1:2*ny+joff,:,1) ! east - data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,4) ! west - data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,3) ! south - data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,3) ! north - data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,1) ! southeast - data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,2) ! southwest - data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & + halo_data(nx+1+ioff:nx+ehalo+ioff, 1: ny+joff,:) = data_all(1+ioff:ehalo+ioff, ny+1:2*ny+joff,:,1) ! east + halo_data(1-whalo:0, 1:ny+joff,:) = data_all(nx-whalo+1:nx, 1:ny+joff,:,4) ! west + halo_data(1:nx+ioff, 1-shalo:0,:) = data_all(1:nx+ioff, ny-shalo+1:ny,:,3) ! south + halo_data(1:nx+ioff, ny+1+joff:ny+nhalo+joff,:) = data_all(1:nx+ioff, 1+joff:nhalo+joff,:,3) ! north + halo_data(nx+1+ioff:nx+ehalo+ioff, 1-shalo:0,:) = data_all(1+ioff:ehalo+ioff, ny-shalo+1:ny,:,1) ! southeast + halo_data(1-whalo:0, 1-shalo:0,:) = data_all(nx-whalo+1:nx, ny-shalo+1:ny,:,2) ! southwest + halo_data(nx+1+ioff:nx+ehalo+ioff,ny+1+joff:ny+nhalo+joff,:) = & & data_all(1+ioff:ehalo+ioff,1+joff:nhalo+joff,:,1) ! northeast - data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,2) ! northwest + halo_data(1-whalo:0, ny+1+joff:ny+nhalo+joff,:) = data_all(nx-whalo+1:nx, 1+joff:nhalo+joff,:,2) ! northwest end select end subroutine fill_five_tile_halo @@ -5294,29 +5303,30 @@ subroutine test_get_boundary(type) end subroutine test_get_boundary !####################################################################################### - subroutine fill_regular_refinement_halo( data, data_all, ni, nj, tm, te, tse, ts, tsw, tw, tnw, tn, tne, ioff, joff ) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_regular_refinement_halo( halo_data, data_all, ni, nj, tm, te, tse, ts, & + tsw, tw, tnw, tn, tne, ioff, joff ) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tm, te, tse, ts, tsw, tw, tnw, tn, tne integer, intent(in) :: ioff, joff - if(te>0) data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & + if(te>0) halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1:nj(tm)+joff, :) = & data_all(1+ioff:ehalo+ioff, 1:nj(te)+joff, :,te) ! east - if(ts>0) data (1:ni(tm)+ioff, 1-shalo:0, :) = & + if(ts>0) halo_data (1:ni(tm)+ioff, 1-shalo:0, :) = & data_all(1:ni(ts)+ioff, nj(ts)-shalo+1:nj(ts), :,ts) ! south - if(tw>0) data (1-whalo:0, 1:nj(tm)+joff, :) = & + if(tw>0) halo_data (1-whalo:0, 1:nj(tm)+joff, :) = & data_all(ni(tw)-whalo+1:ni(tw), 1:nj(tw)+joff, :,tw) ! west - if(tn>0) data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tn>0) halo_data (1:ni(tm)+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1:ni(tn)+ioff, 1+joff:nhalo+joff, :,tn) ! north - if(tse>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & + if(tse>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, 1-shalo:0, :) = & data_all(1+ioff:ehalo+ioff, nj(tse)-shalo+1:nj(tse), :,tse) ! southeast - if(tsw>0)data (1-whalo:0, 1-shalo:0, :) = & + if(tsw>0)halo_data (1-whalo:0, 1-shalo:0, :) = & data_all(ni(tsw)-whalo+1:ni(tsw), nj(tsw)-shalo+1:nj(tsw), :,tsw) ! southwest - if(tne>0)data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tne>0)halo_data (ni(tm)+1+ioff:ni(tm)+ehalo+ioff, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(1+ioff:ehalo+ioff, 1+joff:nhalo+joff, :,tnw) ! northeast - if(tnw>0)data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & + if(tnw>0)halo_data (1-whalo:0, nj(tm)+1+joff:nj(tm)+nhalo+joff, :) = & data_all(ni(tnw)-whalo+1:ni(tnw), 1+joff:nhalo+joff, :,tne) ! northwest end subroutine fill_regular_refinement_halo @@ -5324,8 +5334,8 @@ end subroutine fill_regular_refinement_halo !############################################################################## ! this routine fill the halo points for the refined cubic grid. ioff and joff is used to distinguish ! T, C, E, or N-cell - subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2) - real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: data + subroutine fill_cubicgrid_refined_halo(halo_data, data1_all, data2_all, ni, nj, tile, ioff, joff, sign1, sign2) + real, dimension(1-whalo:,1-shalo:,:), intent(inout) :: halo_data real, dimension(:,:,:,:), intent(in) :: data1_all, data2_all integer, dimension(:), intent(in) :: ni, nj integer, intent(in) :: tile, ioff, joff, sign1, sign2 @@ -5337,20 +5347,20 @@ subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, if(ls < 1 ) ls = ls + 6 if(ln > 6 ) ln = ln - 6 if( nj(tile) == nj(lw) ) then - data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw) ! west + halo_data(1-whalo:0, 1:nj(tile)+joff, :) = data1_all(ni(lw)-whalo+1:ni(lw), 1:nj(lw)+joff, :, lw) ! west end if if( nj(tile) == ni(le) ) then do i = 1, ehalo - data(ni(tile)+i+ioff, 1:nj(tile)+joff, :) = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le) ! east + halo_data(ni(tile)+i+ioff, 1:nj(tile)+joff, :) = sign1*data2_all(ni(le)+joff:1:-1, i+ioff, :, le) ! east end do end if if(ni(tile) == nj(ls) ) then do i = 1, shalo - data(1:ni(tile)+ioff, 1-i, :) = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls) ! south + halo_data(1:ni(tile)+ioff, 1-i, :) = sign2*data2_all(ni(ls)-i+1, nj(ls)+ioff:1:-1, :, ls) ! south end do end if if(ni(tile) == ni(ln) ) then - data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = & + halo_data(1:ni(tile)+ioff, nj(tile)+1+joff:nj(tile)+nhalo+joff, :) = & & data1_all(1:ni(ln)+ioff, 1+joff:nhalo+joff, :, ln) ! north end if else ! tile 1, 3, 5 @@ -5360,34 +5370,34 @@ subroutine fill_cubicgrid_refined_halo(data, data1_all, data2_all, ni, nj, tile, if(ln > 6 ) ln = ln - 6 if(nj(tile) == ni(lw) ) then do i = 1, whalo - data(1-i, 1:nj(tile)+joff, :) = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw) ! west + halo_data(1-i, 1:nj(tile)+joff, :) = sign1*data2_all(ni(lw)+joff:1:-1, nj(lw)-i+1, :, lw) ! west end do end if if(nj(tile) == nj(le) ) then - data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = & + halo_data(ni(tile)+1+ioff:ni(tile)+ehalo+ioff, 1:nj(tile)+joff, :) = & & data1_all(1+ioff:ehalo+ioff, 1:nj(le)+joff, :, le) ! east end if if(ni(tile) == ni(ls) ) then - data(1:ni(tile)+ioff, 1-shalo:0, :) = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls) ! south + halo_data(1:ni(tile)+ioff, 1-shalo:0, :) = data1_all(1:ni(ls)+ioff, nj(ls)-shalo+1:nj(ls), :, ls) ! south end if if(ni(tile) == nj(ln) ) then do i = 1, nhalo - data(1:ni(tile)+ioff, nj(tile)+i+joff, :) = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln) ! north + halo_data(1:ni(tile)+ioff, nj(tile)+i+joff, :) = sign2*data2_all(i+joff, nj(ln)+ioff:1:-1, :, ln) ! north end do end if end if end subroutine fill_cubicgrid_refined_halo - subroutine set_corner_zero( data, isd, ied, jsd, jed, isc, iec, jsc, jec ) + subroutine set_corner_zero( corner_data, isd, ied, jsd, jed, isc, iec, jsc, jec ) integer, intent(in) :: isd, ied, jsd, jed integer, intent(in) :: isc, iec, jsc, jec - real, dimension(isd:,jsd:,:), intent(inout) :: data + real, dimension(isd:,jsd:,:), intent(inout) :: corner_data - data (isd :isc-1, jsd :jsc-1,:) = 0 - data (isd :isc-1, jec+1:jed, :) = 0 - data (iec+1:ied , jsd :jsc-1,:) = 0 - data (iec+1:ied , jec+1:jed, :) = 0 + corner_data (isd :isc-1, jsd :jsc-1,:) = 0 + corner_data (isd :isc-1, jec+1:jed, :) = 0 + corner_data (iec+1:ied , jsd :jsc-1,:) = 0 + corner_data (iec+1:ied , jec+1:jed, :) = 0 end subroutine set_corner_zero diff --git a/test_fms/mpp/test_mpp_gatscat.F90 b/test_fms/mpp/test_mpp_gatscat.F90 index d5709b91c7..5e5646487b 100644 --- a/test_fms/mpp/test_mpp_gatscat.F90 +++ b/test_fms/mpp/test_mpp_gatscat.F90 @@ -121,7 +121,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r4_kind), allocatable, dimension(:,:) :: data !!Data to be scattered + real(kind=r4_kind), allocatable, dimension(:,:) :: scatter_data !!Data to be scattered real(kind=r4_kind), allocatable, dimension(:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -130,7 +130,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) DS = 7 !! DS should be less than 10 for the tests below to make sense. SS = 6 - allocate(data(DS, DS)) + allocate(scatter_data(DS, DS)) allocate(segment(SS, SS)) !!The full PE list [0, ...,npes-1] @@ -139,7 +139,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -147,7 +147,7 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + scatter_data(i,j) = i*10 + j enddo enddo !! And re-initalize segment on the root pe. @@ -170,9 +170,9 @@ subroutine test_scatter_2D_R4(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() ! @@ -227,7 +227,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r8_kind), allocatable, dimension(:,:) :: data !!Data to be scattered + real(kind=r8_kind), allocatable, dimension(:,:) :: scatter_data !!Data to be scattered real(kind=r8_kind), allocatable, dimension(:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -237,7 +237,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) DS = 7 !! DS should be less than 10 for the tests below to make sense. SS = 6 - allocate(data(DS, DS)) + allocate(scatter_data(DS, DS)) allocate(segment(SS, SS)) !!The full PE list [0, ...,npes-1] @@ -246,7 +246,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -254,7 +254,7 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + scatter_data(i,j) = i*10 + j enddo enddo !! And re-initalize segment on the root pe. @@ -277,9 +277,9 @@ subroutine test_scatter_2D_R8(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -334,7 +334,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r4_kind), allocatable, dimension(:,:,:) :: data !!Data to be scattered + real(kind=r4_kind), allocatable, dimension(:,:,:) :: scatter_data !!Data to be scattered real(kind=r4_kind), allocatable, dimension(:,:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -346,7 +346,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) NZ = 11 !! Depth of the square tube to be scattered. DS = 6 !! DS should be less than 10 for the tests below to make sense. SS = 5 !! Can be different that DS, but see retrictions. - allocate(data(DS, DS, NZ)) + allocate(scatter_data(DS, DS, NZ)) allocate(segment(SS, SS, NZ)) !!The full PE list is [0, ...,npes-1] @@ -355,7 +355,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -364,7 +364,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + scatter_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -372,7 +372,7 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) do i = 1,SS do j = 1,SS do k = 1,NZ - segment(i,j, k) = data(i,j, k) + segment(i,j, k) = scatter_data(i,j, k) enddo enddo enddo @@ -390,9 +390,9 @@ subroutine test_scatter_3D_R4(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -464,7 +464,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k - real(kind=r8_kind), allocatable, dimension(:,:,:) :: data !!Data to be scattered + real(kind=r8_kind), allocatable, dimension(:,:,:) :: scatter_data !!Data to be scattered real(kind=r8_kind), allocatable, dimension(:,:,:) :: segment integer :: DS, SS !!Source data size and segment size integer :: iz, jz !!The zeroth element to be scattered is at pos data(is+iz, js+jz) @@ -476,7 +476,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) NZ = 11 !! Depth of the square tube to be scattered. DS = 6 !! DS should be less than 10 for the tests below to make sense. SS = 5 !! Can be different that DS, but see retrictions. - allocate(data(DS, DS, NZ)) + allocate(scatter_data(DS, DS, NZ)) allocate(segment(SS, SS, NZ)) !!The full PE list is [0, ...,npes-1] @@ -485,7 +485,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + scatter_data = -1 segment = -2.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula @@ -494,7 +494,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + scatter_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -502,7 +502,7 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) do i = 1,SS do j = 1,SS do k = 1,NZ - segment(i,j, k) = data(i,j, k) + segment(i,j, k) = scatter_data(i,j, k) enddo enddo enddo @@ -520,9 +520,9 @@ subroutine test_scatter_3D_R8(npes,pe,root,out_unit) js = 2 je = 3 if(pe .eq. root) then - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, data, .true., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes-1), segment, scatter_data, .true., iz, jz) else - call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, data, .false., iz, jz) + call mpp_scatter(is, ie, js, je, NZ, pelist(1:npes -1), segment, scatter_data, .false., iz, jz) endif call mpp_sync() @@ -787,7 +787,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) integer :: pelist(npes),rsize(npes) integer :: pelist2(npes),rsize2(npes) integer :: i,j,k,l,nz,ssize,nelems - real,allocatable,dimension(:,:) :: data, cdata, sbuff,rbuff + real,allocatable,dimension(:,:) :: gather_data, cdata, sbuff,rbuff real,allocatable :: ref(:,:) integer, parameter :: KSIZE=10 @@ -805,9 +805,9 @@ subroutine test_gather2DV(npes,pe,root,out_unit) write(out_unit,*) ssize = pe+1 - allocate(data(ssize,KSIZE)) + allocate(gather_data(ssize,KSIZE)) do k=1,KSIZE; do i=1,ssize - data(i,k) = 10000.0*k + pe + 0.0001*i + gather_data(i,k) = 10000.0*k + pe + 0.0001*i enddo; enddo do i=1,npes pelist(i) = i-1 @@ -834,7 +834,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) ! and a clear, concise unpack do j=1,ssize do i=1,nz - sbuff(i,j) = data(j,i) + sbuff(i,j) = gather_data(j,i) enddo; enddo ! Note that the gatherV implied here is asymmetric; only root needs to know the vector of recv size @@ -892,7 +892,7 @@ subroutine test_gather2DV(npes,pe,root,out_unit) endif call mpp_sync() write(out_unit,*) "Test gather2DV with reversed pelist successful" - deallocate(data,sbuff,rbuff,cdata,ref) + deallocate(gather_data,sbuff,rbuff,cdata,ref) end subroutine test_gather2DV end program test_mpp_gatscat diff --git a/test_fms/mpp/test_mpp_sendrecv.F90 b/test_fms/mpp/test_mpp_sendrecv.F90 index 5f82683e14..c90b7bbfcc 100644 --- a/test_fms/mpp/test_mpp_sendrecv.F90 +++ b/test_fms/mpp/test_mpp_sendrecv.F90 @@ -119,11 +119,11 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j, p - real(kind=r4_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + real(kind=r4_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data (DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -131,14 +131,14 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10.0 + j*1.0 + sendrecv_data(i,j) = i*10.0 + j*1.0 enddo enddo endif @@ -147,10 +147,10 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -159,7 +159,7 @@ subroutine test_sendrecv_2D_R4(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i*10.0 + j*1.0)) then + if (sendrecv_data(i,j) /= ( i*10.0 + j*1.0)) then call mpp_error(FATAL, "Test sendrecv 2D R4 failed - basic copy area.") endif enddo @@ -177,11 +177,11 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j, p - real(kind=r8_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + real(kind=r8_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -189,14 +189,14 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10.0 + j*1.0 + sendrecv_data(i,j) = i*10.0 + j*1.0 enddo enddo endif @@ -205,10 +205,10 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -218,7 +218,7 @@ subroutine test_sendrecv_2D_R8(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i*10.0 + j*1.0)) then + if (sendrecv_data(i,j) /= ( i*10.0 + j*1.0)) then call mpp_error(FATAL, "Test sendrecv 2D R8 failed - basic copy area.") endif enddo @@ -236,7 +236,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k, p - real(kind=r4_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + real(kind=r4_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -245,7 +245,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -253,7 +253,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -261,7 +261,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100.0 + j*10.0 + i*1.0 + sendrecv_data(i,j, k) = k*100.0 + j*10.0 + i*1.0 enddo enddo enddo @@ -272,10 +272,10 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -286,7 +286,7 @@ subroutine test_sendrecv_3D_R4(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then + if (sendrecv_data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then call mpp_error(FATAL, "Test sendrecv 3D R4 failed - basic copy area.") endif enddo @@ -307,7 +307,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) integer :: pelist(npes) integer :: i,j,k, p - real(kind=r8_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + real(kind=r8_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -316,7 +316,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -324,7 +324,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1.0 + sendrecv_data = -1.0 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -332,7 +332,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100.0 + j*10.0 + i*1.0 + sendrecv_data(i,j, k) = k*100.0 + j*10.0 + i*1.0 enddo enddo enddo @@ -343,10 +343,10 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -357,7 +357,7 @@ subroutine test_sendrecv_3D_R8(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then + if (sendrecv_data(i,j, k) /= ( k*100.0 + j*10.0 + i*1.0 )) then call mpp_error(FATAL, "Test sendrecv 3D R8 failed - basic copy area.") endif enddo @@ -377,11 +377,11 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i4_kind) :: i,j - integer(kind=i4_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + integer(kind=i4_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS, p DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -389,14 +389,14 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + sendrecv_data(i,j) = i*10 + j enddo enddo endif @@ -405,10 +405,10 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -417,7 +417,7 @@ subroutine test_sendrecv_2D_I4(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i * 10 + j )) then + if (sendrecv_data(i,j) /= ( i * 10 + j )) then call mpp_error(FATAL, "Test sendrecv 2D I4 failed - basic copy area.") endif enddo @@ -435,11 +435,11 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i8_kind) :: i,j - integer(kind=i8_kind), allocatable, dimension(:,:) :: data !!Data to be sendrecved + integer(kind=i8_kind), allocatable, dimension(:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS, p DS = 9 - allocate(data(DS, DS)) + allocate(sendrecv_data(DS, DS)) !!The full PE list [0, ...,npes-1] do i=0,npes-1 @@ -447,14 +447,14 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4) is 34.000, etc. if (pe == root) then do i = 1,DS do j = 1,DS - data(i,j) = i*10 + j + sendrecv_data(i,j) = i*10 + j enddo enddo endif @@ -463,10 +463,10 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS, p ) + call mpp_send( sendrecv_data, DS* DS, p ) end do else - call mpp_recv( data, DS * DS, 0 ) + call mpp_recv( sendrecv_data, DS * DS, 0 ) end if call mpp_sync() ! Needed ? @@ -475,7 +475,7 @@ subroutine test_sendrecv_2D_I8(npes,pe,root,out_unit) if(ANY(pe == pelist(1:npes-1))) then do j = 1, DS do i = 1, DS - if (data(i,j) /= ( i * 10 + j )) then + if (sendrecv_data(i,j) /= ( i * 10 + j )) then call mpp_error(FATAL, "Test sendrecv 2D I8 failed - basic copy area.") endif enddo @@ -493,7 +493,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i4_kind) :: i,j,k - integer(kind=i4_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + integer(kind=i4_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -502,7 +502,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -510,7 +510,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -518,7 +518,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + sendrecv_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -529,10 +529,10 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -543,7 +543,7 @@ subroutine test_sendrecv_3D_I4(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k * 100 + j*10 + i )) then + if (sendrecv_data(i,j, k) /= ( k * 100 + j*10 + i )) then call mpp_error(FATAL, "Test sendrecv 3D I4 failed - basic copy area.") endif enddo @@ -563,7 +563,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) integer :: pelist(npes) integer(kind=i8_kind) :: i,j,k - integer(kind=i8_kind), allocatable, dimension(:,:,:) :: data !!Data to be sendrecved + integer(kind=i8_kind), allocatable, dimension(:,:,:) :: sendrecv_data !!Data to be sendrecved integer :: DS integer :: iz, jz !!The zeroth element to be sendrecved is at pos data(is+iz, js+jz) integer :: is, ie, js, je !!The amount of data to be sendrecved is (ie - is)*(je - js) @@ -572,7 +572,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) NZ = 9 !! Depth of the square tube to be sendrecved. DS = 8 !! DS should be less than 10 for the tests below to make sense. - allocate(data(DS, DS, NZ)) + allocate(sendrecv_data(DS, DS, NZ)) !!The full PE list is [0, ...,npes-1] do i=0,npes-1 @@ -580,7 +580,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) enddo !!Initialize all data on all PEs - data = -1 + sendrecv_data = -1 !! Re-initialize data on the root PE only. !! Data is such that we can calculate what it should be with a Formula !! using the indecies. E.g.. data(3,4,5) is 543.000, etc. @@ -588,7 +588,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) do i = 1,DS do j = 1,DS do k = 1,NZ - data(i,j, k) = k*100 + j*10 + i + sendrecv_data(i,j, k) = k*100 + j*10 + i enddo enddo enddo @@ -599,10 +599,10 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) !! And receive from all other pes if ( pe == root ) then do p = 1,npes-1 - call mpp_send( data, DS* DS* NZ, p ) + call mpp_send( sendrecv_data, DS* DS* NZ, p ) end do else - call mpp_recv( data, DS * DS * NZ, 0 ) + call mpp_recv( sendrecv_data, DS * DS * NZ, 0 ) end if call mpp_sync() ! Needed ? @@ -613,7 +613,7 @@ subroutine test_sendrecv_3D_I8(npes,pe,root,out_unit) do k = 1, NZ do j = 1, DS do i = 1, DS - if (data(i,j, k) /= ( k * 100 + j*10 + i )) then + if (sendrecv_data(i,j, k) /= ( k * 100 + j*10 + i )) then call mpp_error(FATAL, "Test sendrecv 3D I8 failed - basic copy area.") endif enddo diff --git a/time_interp/include/time_interp_external2.inc b/time_interp/include/time_interp_external2.inc index b4e6114e6d..863941df1d 100644 --- a/time_interp/include/time_interp_external2.inc +++ b/time_interp/include/time_interp_external2.inc @@ -52,13 +52,13 @@ !! Provide data from external file interpolated to current model time. !! Data may be local to current processor or global, depending on !! "init_external_field" flags. - subroutine TIME_INTERP_EXTERNAL_3D_(index, time, data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & + subroutine TIME_INTERP_EXTERNAL_3D_(index, time, time_data, interp,verbose,horz_interp, mask_out, is_in, ie_in, & & js_in, je_in, window_id) integer, intent(in) :: index !< index of external field from previous call !! to init_external_field type(time_type), intent(in) :: time !< target time for data - real(FMS_TI_KIND_), dimension(:,:,:), intent(inout) :: data !< global or local data array + real(FMS_TI_KIND_), dimension(:,:,:), intent(inout) :: time_data !< global or local data array integer, intent(in), optional :: interp logical, intent(in), optional :: verbose !< flag for debugging type(horiz_interp_type), intent(in), optional :: horz_interp @@ -82,9 +82,9 @@ character(len=16) :: message1, message2 integer, parameter :: kindl = FMS_TI_KIND_ - nx = size(data,1) - ny = size(data,2) - nz = size(data,3) + nx = size(time_data,1) + ny = size(time_data,2) + nz = size(time_data,3) interp_method = LINEAR_TIME_INTERP if (PRESENT(interp)) interp_method = interp @@ -141,14 +141,16 @@ i1 = find_buf_index(1,loaded_fields(index)%ibuf) if( loaded_fields(index)%region_type == NO_REGION ) then where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), FMS_TI_KIND_) + time_data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1),& + FMS_TI_KIND_) elsewhere - ! data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, FMS_TI_KIND_) + ! time_data(isw:iew,jsw:jew,:) = time_interp_missing !field(index)%missing? Balaji + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, FMS_TI_KIND_) end where else where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1)) - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), FMS_TI_KIND_) + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1),& + FMS_TI_KIND_) end where endif if(PRESENT(mask_out)) mask_out(isw:iew,jsw:jew,:) = loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) @@ -201,17 +203,17 @@ if( loaded_fields(index)%region_type == NO_REGION ) then where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) .and. & loaded_fields(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), kindl) * w1 + & - real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i2), kindl) * w2 + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1), kindl)& + * w1 + real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i2), kindl) * w2 elsewhere - ! data(isw:iew,jsw:jew,:) = time_interp_missing !loaded_fields(index)%missing? Balaji - data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, kindl) + ! time_data(isw:iew,jsw:jew,:) = time_interp_missing !loaded_fields(index)%missing? Balaji + time_data(isw:iew,jsw:jew,:) = real(loaded_fields(index)%missing, kindl) end where else where(loaded_fields(index)%mask(isc:iec,jsc:jec,:,i1) .and. & loaded_fields(index)%mask(isc:iec,jsc:jec,:,i2)) - data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%data(isc:iec,jsc:jec,:,i1), kindl) * w1 + & - real(loaded_fields(index)%data(isc:iec,jsc:jec,:,i2), kindl) * w2 + time_data(isw:iew,jsw:jew,:) = real( loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i1), kindl)& + * w1 + real(loaded_fields(index)%domain_data(isc:iec,jsc:jec,:,i2), kindl) * w2 end where endif if(PRESENT(mask_out)) & @@ -224,11 +226,11 @@ ! NAME="time_interp_external" !> @brief Scalar interpolation for @ref time_interp_external - subroutine TIME_INTERP_EXTERNAL_0D_(index, time, data, verbose) + subroutine TIME_INTERP_EXTERNAL_0D_(index, time, time_data, verbose) integer, intent(in) :: index type(time_type), intent(in) :: time - real(FMS_TI_KIND_), intent(inout) :: data + real(FMS_TI_KIND_), intent(inout) :: time_data logical, intent(in), optional :: verbose integer :: t1, t2 @@ -252,7 +254,7 @@ ! only one record in the file => time-independent loaded_fields call load_record_0d(loaded_fields(index),1) i1 = find_buf_index(1,loaded_fields(index)%ibuf) - data = real(loaded_fields(index)%data(1,1,1,i1), FMS_TI_KIND_) + time_data = real(loaded_fields(index)%domain_data(1,1,1,i1), FMS_TI_KIND_) else if(loaded_fields(index)%have_modulo_times) then call time_interp(time,loaded_fields(index)%modulo_time_beg, loaded_fields(index)%modulo_time_end, & @@ -290,8 +292,8 @@ if(i1<0.or.i2<0) & call mpp_error(FATAL,'time_interp_external : records were not loaded correctly in memory') - data = real(loaded_fields(index)%data(1,1,1,i1), FMS_TI_KIND_)*w1 & - & + real(loaded_fields(index)%data(1,1,1,i2), FMS_TI_KIND_)*w2 + time_data = real(loaded_fields(index)%domain_data(1,1,1,i1), FMS_TI_KIND_)*w1 & + & + real(loaded_fields(index)%domain_data(1,1,1,i2), FMS_TI_KIND_)*w2 if (verb) then write(outunit,*) 'ibuf= ',loaded_fields(index)%ibuf write(outunit,*) 'i1,i2= ',i1, i2 diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index d5514a9462..67e5127188 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -102,7 +102,7 @@ module time_interp_external2_mod type(time_type), dimension(:), pointer :: start_time =>NULL(), end_time =>NULL() type(time_type), dimension(:), pointer :: period =>NULL() logical :: modulo_time !< denote climatological time axis - real(r8_kind), dimension(:,:,:,:), pointer :: data =>NULL() !< defined over data domain or global domain + real(r8_kind), dimension(:,:,:,:), pointer :: domain_data =>NULL() !< defined over data domain or global domain logical, dimension(:,:,:,:), pointer :: mask =>NULL() !< defined over data domain or global domain integer, dimension(:), pointer :: ibuf =>NULL() !< record numbers associated with buffers real(r8_kind), dimension(:,:,:,:), pointer :: src_data =>NULL() !< input data buffer @@ -556,10 +556,10 @@ function init_external_field(file,fieldname,domain,desired_units,& allocate(loaded_fields(num_fields)%need_compute(nbuf, numwindows)) loaded_fields(num_fields)%need_compute = .true. - allocate(loaded_fields(num_fields)%data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& + allocate(loaded_fields(num_fields)%domain_data(isdata:iedata,jsdata:jedata,siz(3),nbuf),& loaded_fields(num_fields)%mask(isdata:iedata,jsdata:jedata,siz(3),nbuf) ) loaded_fields(num_fields)%mask = .false. - loaded_fields(num_fields)%data = 0.0_r8_kind + loaded_fields(num_fields)%domain_data = 0.0_r8_kind slope=1.0_r8_kind;intercept=0.0_r8_kind ! if (units /= 'same') call convert_units(trim(field(num_fields)%units),trim(units),slope,intercept) ! if (verb.and.units /= 'same') then @@ -756,7 +756,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id integer :: window_id real(r8_kind) :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) real(r8_kind), allocatable :: mask_out(:,:,:) - real(r4_kind), allocatable :: hi_tmp_data(:,:,:,:) !< used to hold a copy of field%data if using r4_kind + real(r4_kind), allocatable :: hi_tmp_data(:,:,:,:) !< used to hold a copy of field%domain_data if using r4_kind real(r4_kind), allocatable :: hi_tmp_msk_out(:,:,:) !< used return the field mask if using r4_kind real(r4_kind), allocatable :: hi_tmp_src_data(:,:,:,:) !< used return the field mask if using r4_kind @@ -773,7 +773,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id else ! calculate current buffer number in round-robin fasion field%nbuf = field%nbuf + 1 - if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 + if(field%nbuf > size(field%domain_data,4).or.field%nbuf <= 0) field%nbuf = 1 ib = field%nbuf field%ibuf(ib) = rec field%need_compute(ib,:) = .true. @@ -834,22 +834,22 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id if (interp%horizInterpReals4_type%is_allocated) then ! allocate (there may be a better way to do this, had issues with gnu) allocate(hi_tmp_msk_out(isw:iew,jsw:jew, SIZE(field%src_data,3))) - allocate(hi_tmp_data(LBOUND(field%data,1):UBOUND(field%data,1), & - LBOUND(field%data,2):UBOUND(field%data,2), & - LBOUND(field%data,3):UBOUND(field%data,3), & - LBOUND(field%data,4):UBOUND(field%data,4))) + allocate(hi_tmp_data(LBOUND(field%domain_data,1):UBOUND(field%domain_data,1), & + LBOUND(field%domain_data,2):UBOUND(field%domain_data,2), & + LBOUND(field%domain_data,3):UBOUND(field%domain_data,3), & + LBOUND(field%domain_data,4):UBOUND(field%domain_data,4))) allocate(hi_tmp_src_data(LBOUND(field%src_data,1):UBOUND(field%src_data,1), & LBOUND(field%src_data,2):UBOUND(field%src_data,2), & LBOUND(field%src_data,3):UBOUND(field%src_data,3), & LBOUND(field%src_data,4):UBOUND(field%src_data,4))) ! assign if needed - hi_tmp_data = real(field%data, r4_kind) + hi_tmp_data = real(field%domain_data, r4_kind) hi_tmp_src_data = real(field%src_data, r4_kind) ! do interpolation call horiz_interp(interp, hi_tmp_src_data(:,:,:,ib), hi_tmp_data(isw:iew,jsw:jew,:,ib), & mask_in=real(mask_in,r4_kind), mask_out=hi_tmp_msk_out) ! assign any output - field%data = real(hi_tmp_data, r8_kind) + field%domain_data = real(hi_tmp_data, r8_kind) field%mask(isw:iew,jsw:jew,:,ib) = hi_tmp_msk_out(isw:iew,jsw:jew,:) > 0.0_r4_kind if(allocated(hi_tmp_data)) deallocate(hi_tmp_data) @@ -857,7 +857,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id if(allocated(hi_tmp_src_data)) deallocate(hi_tmp_src_data) else allocate(mask_out(isw:iew,jsw:jew, size(field%src_data,3))) - call horiz_interp(interp, field%src_data(:,:,:,ib),field%data(isw:iew,jsw:jew,:,ib), & + call horiz_interp(interp, field%src_data(:,:,:,ib),field%domain_data(isw:iew,jsw:jew,:,ib), & mask_in=mask_in, & mask_out=mask_out) field%mask(isw:iew,jsw:jew,:,ib) = mask_out(isw:iew,jsw:jew,:) > 0.0_r8_kind @@ -868,12 +868,12 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id if ( field%region_type .NE. NO_REGION ) then call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when interp is not present") endif - field%data(isw:iew,jsw:jew,:,ib) = field%src_data(isw:iew,jsw:jew,:,ib) - field%mask(isw:iew,jsw:jew,:,ib) = is_valid(field%data(isw:iew,jsw:jew,:,ib),field%valid) + field%domain_data(isw:iew,jsw:jew,:,ib) = field%src_data(isw:iew,jsw:jew,:,ib) + field%mask(isw:iew,jsw:jew,:,ib) = is_valid(field%domain_data(isw:iew,jsw:jew,:,ib),field%valid) endif ! convert units - where(field%mask(isw:iew,jsw:jew,:,ib)) field%data(isw:iew,jsw:jew,:,ib) = & - field%data(isw:iew,jsw:jew,:,ib)*field%slope + field%intercept + where(field%mask(isw:iew,jsw:jew,:,ib)) field%domain_data(isw:iew,jsw:jew,:,ib) = & + field%domain_data(isw:iew,jsw:jew,:,ib)*field%slope + field%intercept field%need_compute(ib, window_id) = .false. endif @@ -895,7 +895,7 @@ subroutine load_record_0d(field, rec) else ! calculate current buffer number in round-robin fasion field%nbuf = field%nbuf + 1 - if(field%nbuf > size(field%data,4).or.field%nbuf <= 0) field%nbuf = 1 + if(field%nbuf > size(field%domain_data,4).or.field%nbuf <= 0) field%nbuf = 1 ib = field%nbuf field%ibuf(ib) = rec @@ -907,11 +907,11 @@ subroutine load_record_0d(field, rec) if ( field%region_type .NE. NO_REGION ) then call mpp_error(FATAL, "time_interp_external: region_type should be NO_REGION when field is scalar") endif - field%data(1,1,:,ib) = field%src_data(1,1,:,ib) - field%mask(1,1,:,ib) = is_valid(field%data(1,1,:,ib),field%valid) + field%domain_data(1,1,:,ib) = field%src_data(1,1,:,ib) + field%mask(1,1,:,ib) = is_valid(field%domain_data(1,1,:,ib),field%valid) ! convert units - where(field%mask(1,1,:,ib)) field%data(1,1,:,ib) = & - field%data(1,1,:,ib)*field%slope + field%intercept + where(field%mask(1,1,:,ib)) field%domain_data(1,1,:,ib) = & + field%domain_data(1,1,:,ib)*field%slope + field%intercept endif end subroutine load_record_0d @@ -1005,7 +1005,7 @@ subroutine realloc_fields(n) if (ASSOCIATED(ptr(i)%end_time)) DEALLOCATE(ptr(i)%end_time, stat=ier) if (ASSOCIATED(ptr(i)%period)) DEALLOCATE(ptr(i)%period, stat=ier) ptr(i)%modulo_time=.false. - if (ASSOCIATED(ptr(i)%data)) DEALLOCATE(ptr(i)%data, stat=ier) + if (ASSOCIATED(ptr(i)%domain_data)) DEALLOCATE(ptr(i)%domain_data, stat=ier) if (ASSOCIATED(ptr(i)%ibuf)) DEALLOCATE(ptr(i)%ibuf, stat=ier) if (ASSOCIATED(ptr(i)%src_data)) DEALLOCATE(ptr(i)%src_data, stat=ier) ptr(i)%nbuf=-1 @@ -1103,7 +1103,7 @@ subroutine time_interp_external_exit() ! do i=1,num_fields deallocate(loaded_fields(i)%time,loaded_fields(i)%start_time,loaded_fields(i)%end_time,& - loaded_fields(i)%period,loaded_fields(i)%data,loaded_fields(i)%mask,loaded_fields(i)%ibuf) + loaded_fields(i)%period,loaded_fields(i)%domain_data,loaded_fields(i)%mask,loaded_fields(i)%ibuf) if (ASSOCIATED(loaded_fields(i)%src_data)) deallocate(loaded_fields(i)%src_data) loaded_fields(i)%domain = NULL_DOMAIN2D loaded_fields(i)%nbuf = 0