FMS 2025.01-dev
Flexible Modeling System
Loading...
Searching...
No Matches
coupler_types.inc
1!***********************************************************************
2!* GNU Lesser General Public License
3!*
4!* This file is part of the GFDL Flexible Modeling System (FMS).
5!*
6!* FMS is free software: you can redistribute it and/or modify it under
7!* the terms of the GNU Lesser General Public License as published by
8!* the Free Software Foundation, either version 3 of the License, or (at
9!* your option) any later version.
10!*
11!* FMS is distributed in the hope that it will be useful, but WITHOUT
12!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14!* for more details.
15!*
16!* You should have received a copy of the GNU Lesser General Public
17!* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18!***********************************************************************
19!> @defgroup coupler_types_mod coupler_types_mod
20!> @ingroup coupler
21!> @brief This module contains type declarations for the coupler.
22!> @author Richard Slater, John Dunne
23
24!> @addtogroup coupler_types_mod
25!> @{
26
27!> @addtogroup coupler_types_mod
28!> @{
29
30 !> @brief Rescales the fields in the fields in the elements of a coupler_2d_bc_type
31 !!
32 !! Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale.
33 !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist.
34 subroutine ct_rescale_data_2d_(var, scale, halo_size, bc_index, field_index,&
35 & exclude_flux_type, only_flux_type, pass_through_ice)
36 type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled
37 real(FMS_CP_KIND_), intent(in) :: scale !< A scaling factor to multiply fields by
38 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or
39 !! the full arrays if scale is 0.
40 integer, optional, intent(in) :: bc_index !< The index of the boundary condition
41 !! that is being copied
42 integer, optional, intent(in) :: field_index !< The index of the field in the
43 !! boundary condition that is being copied
44 character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types
45 !! of fluxes to exclude from this copy.
46 character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types
47 !! of fluxes to include from this copy.
48 logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose
49 !! value of pass_through ice matches this
50
51 logical :: do_bc
52 integer :: i, j, m, n, n1, n2, halo
53 integer, parameter :: kindl = fms_cp_kind_
54
55 if (present(bc_index)) then
56 if (bc_index > var%num_bcs)&
57 & call mpp_error(fatal, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.")
58 if (present(field_index)) then ; if (field_index > var%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
59 & call mpp_error(fatal, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //&
60 & trim(var%FMS_CP_BC_TYPE_(bc_index)%name) )
61 endif
62 elseif (present(field_index)) then
63 call mpp_error(fatal, "CT_rescale_data_2d: bc_index must be present if field_index is present.")
64 endif
65
66 halo = 0
67 if (present(halo_size)) halo = halo_size
68
69 n1 = 1
70 n2 = var%num_bcs
71 if (present(bc_index)) then
72 n1 = bc_index
73 n2 = bc_index
74 endif
75
76 if (n2 >= n1) then
77 ! A more consciencious implementation would include a more descriptive error messages.
78 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
79 & call mpp_error(fatal, "CT_rescale_data_2d: Excessive i-direction halo size.")
80 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
81 & call mpp_error(fatal, "CT_rescale_data_2d: Excessive j-direction halo size.")
82 endif
83
84 do n = n1, n2
85 do_bc = .true.
86 if (do_bc .and. present(exclude_flux_type))&
87 & do_bc = .not.(trim(var%FMS_CP_BC_TYPE_(n)%flux_type) == trim(exclude_flux_type))
88 if (do_bc .and. present(only_flux_type))&
89 & do_bc = (trim(var%FMS_CP_BC_TYPE_(n)%flux_type) == trim(only_flux_type))
90 if (do_bc .and. present(pass_through_ice))&
91 & do_bc = (pass_through_ice .eqv. var%FMS_CP_BC_TYPE_(n)%pass_through_ice)
92 if (.not.do_bc) cycle
93
94 do m = 1, var%FMS_CP_BC_TYPE_(n)%num_fields
95 if (present(field_index)) then
96 if (m /= field_index) cycle
97 endif
98 if ( associated(var%FMS_CP_BC_TYPE_(n)%field(m)%values) ) then
99 if (scale == 0.0_kindl) then
100 if (present(halo_size)) then
101 do j=var%jsc-halo,var%jec+halo
102 do i=var%isc-halo,var%iec+halo
103 var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j) = 0.0_kindl
104 enddo
105 enddo
106 else
107 var%FMS_CP_BC_TYPE_(n)%field(m)%values(:,:) = 0.0_kindl
108 endif
109 else
110 do j=var%jsc-halo,var%jec+halo
111 do i=var%isc-halo,var%iec+halo
112 var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j) = scale * var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j)
113 enddo
114 enddo
115 endif
116 endif
117 enddo
118 enddo
119 end subroutine ct_rescale_data_2d_
120
121 !> @brief Rescales the fields in the elements of a coupler_3d_bc_type
122 !!
123 !! This subroutine rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a
124 !! factor scale. If scale is 0, this is a direct assignment to 0, so that NaNs will not persist.
125 subroutine ct_rescale_data_3d_(var, scale, halo_size, bc_index, field_index,&
126 & exclude_flux_type, only_flux_type, pass_through_ice)
127 type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled
128 real(FMS_CP_KIND_), intent(in) :: scale !< A scaling factor to multiply fields by
129 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default or
130 !! the full arrays if scale is 0.
131 integer, optional, intent(in) :: bc_index !< The index of the boundary condition
132 !! that is being copied
133 integer, optional, intent(in) :: field_index !< The index of the field in the
134 !! boundary condition that is being copied
135 character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types
136 !! of fluxes to exclude from this copy.
137 character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of
138 !! fluxes to include from this copy.
139 logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose
140 !! value of pass_through ice matches this
141
142 logical :: do_bc
143 integer :: i, j, k, m, n, n1, n2, halo
144 integer, parameter :: kindl = fms_cp_kind_
145
146 if (present(bc_index)) then
147 if (bc_index > var%num_bcs)&
148 & call mpp_error(fatal, "CT_rescale_data_2d: bc_index is present and exceeds var%num_bcs.")
149 if (present(field_index)) then ; if (field_index > var%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
150 & call mpp_error(fatal, "CT_rescale_data_2d: field_index is present and exceeds num_fields for" //&
151 & trim(var%FMS_CP_BC_TYPE_(bc_index)%name) )
152 endif
153 elseif (present(field_index)) then
154 call mpp_error(fatal, "CT_rescale_data_2d: bc_index must be present if field_index is present.")
155 endif
156
157 halo = 0
158 if (present(halo_size)) halo = halo_size
159
160 n1 = 1
161 n2 = var%num_bcs
162 if (present(bc_index)) then
163 n1 = bc_index
164 n2 = bc_index
165 endif
166
167 if (n2 >= n1) then
168 ! A more consciencious implementation would include a more descriptive error messages.
169 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
170 & call mpp_error(fatal, "CT_rescale_data_3d: Excessive i-direction halo size.")
171 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
172 & call mpp_error(fatal, "CT_rescale_data_3d: Excessive j-direction halo size.")
173 endif
174
175 do n = n1, n2
176 do_bc = .true.
177 if (do_bc .and. present(exclude_flux_type))&
178 & do_bc = .not.(trim(var%FMS_CP_BC_TYPE_(n)%flux_type) == trim(exclude_flux_type))
179 if (do_bc .and. present(only_flux_type))&
180 & do_bc = (trim(var%FMS_CP_BC_TYPE_(n)%flux_type) == trim(only_flux_type))
181 if (do_bc .and. present(pass_through_ice))&
182 & do_bc = (pass_through_ice .eqv. var%FMS_CP_BC_TYPE_(n)%pass_through_ice)
183 if (.not.do_bc) cycle
184
185 do m = 1, var%FMS_CP_BC_TYPE_(n)%num_fields
186 if (present(field_index)) then
187 if (m /= field_index) cycle
188 endif
189 if ( associated(var%FMS_CP_BC_TYPE_(n)%field(m)%values) ) then
190 if (scale == 0.0_kindl) then
191 if (present(halo_size)) then
192 do k=var%ks,var%ke
193 do j=var%jsc-halo,var%jec+halo
194 do i=var%isc-halo,var%iec+halo
195 var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j,k) = 0.0_kindl
196 enddo
197 enddo
198 enddo
199 else
200 var%FMS_CP_BC_TYPE_(n)%field(m)%values(:,:,:) = 0.0_kindl
201 endif
202 else
203 do k=var%ks,var%ke
204 do j=var%jsc-halo,var%jec+halo
205 do i=var%isc-halo,var%iec+halo
206 var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j,k) = scale * var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j,k)
207 enddo
208 enddo
209 enddo
210 endif
211 endif
212 enddo
213 enddo
214 end subroutine ct_rescale_data_3d_
215
216 !> @brief Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a
217 !! coupler_3d_bc_type
218 !!
219 !! Increments the data in the elements of a coupler_2d_bc_type with the weighed average of the
220 !! elements of a coupler_3d_bc_type. Both must have the same horizontal array sizes and the
221 !! normalized weight array must match the array sizes of the coupler_3d_bc_type.
222 !!
223 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
224 !! @throw FATAL, "field_index is present and exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
225 !! @throw FATAL, "bc_index must be present if field_index is present."
226 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
227 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
228 !! @throw FATAL, "There is an k-direction computational domain size mismatch."
229 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
230 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
231 !! @throw FATAL, "weights array must be the i-size of a computational or data domain."
232 !! @throw FATAL, "weights array must be the j-size of a computational or data domain."
233 subroutine ct_increment_data_2d_3d_(var_in, weights, var, halo_size, bc_index, field_index,&
234 & scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice)
235 type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to add to the other type
236 real(FMS_CP_KIND_), dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data
237 !! to increment the 2d-data. There is no renormalization,
238 !! so if the weights do not sum to 1 in the 3rd dimension
239 !! there may be adverse consequences!
240 type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being incremented
241 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
242 integer, optional, intent(in) :: bc_index !< The index of the boundary condition
243 !! that is being copied
244 integer, optional, intent(in) :: field_index !< The index of the field in the
245 !! boundary condition that is being copied
246 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that
247 !! is being added
248 real(FMS_CP_KIND_), optional, intent(in) :: scale_prev !< A scaling factor for the data that
249 !! is already here and is being added
250 character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types
251 !! of fluxes to exclude from this increment.
252 character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types
253 !! of fluxes to include from this increment.
254 logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose
255 !! value of pass_through ice matches this
256
257 real(FMS_CP_KIND_) :: scale, sc_prev
258 logical :: increment_bc
259 integer :: i, j, k, m, n, n1, n2, halo
260 integer :: io1, jo1, iow, jow, kow ! Offsets to account for different index conventions.
261 integer, parameter :: kindl = fms_cp_kind_
262
263 scale = 1.0_kindl
264 if (present(scale_factor)) scale = scale_factor
265 sc_prev = 1.0_kindl
266 if (present(scale_prev)) sc_prev = scale_prev
267
268 if (present(bc_index)) then
269 if (bc_index > var_in%num_bcs)&
270 & call mpp_error(fatal, "CT_increment_data_2d_3d: bc_index is present and exceeds var_in%num_bcs.")
271 if (present(field_index)) then ; if (field_index > var_in%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
272 & call mpp_error(fatal, "CT_increment_data_2d_3d: field_index is present and exceeds num_fields for" //&
273 & trim(var_in%FMS_CP_BC_TYPE_(bc_index)%name) )
274 endif
275 elseif (present(field_index)) then
276 call mpp_error(fatal, "CT_increment_data_2d_3d: bc_index must be present if field_index is present.")
277 endif
278
279 halo = 0
280 if (present(halo_size)) halo = halo_size
281
282 n1 = 1
283 n2 = var_in%num_bcs
284 if (present(bc_index)) then
285 n1 = bc_index
286 n2 = bc_index
287 endif
288
289 if (n2 >= n1) then
290 ! A more consciencious implementation would include a more descriptive error messages.
291 if ((var_in%iec-var_in%isc) /= (var%iec-var%isc))&
292 & call mpp_error(fatal, &
293 & "CT_increment_data_2d_3d: There is an i-direction computational domain size mismatch.")
294 if ((var_in%jec-var_in%jsc) /= (var%jec-var%jsc))&
295 & call mpp_error(fatal, &
296 & "CT_increment_data_2d_3d: There is a j-direction computational domain size mismatch.")
297 if ((1+var_in%ke-var_in%ks) /= size(weights,3))&
298 & call mpp_error(fatal, &
299 & "CT_increment_data_2d_3d: There is a k-direction size mismatch with the weights array.")
300 if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))&
301 & call mpp_error(fatal, "CT_increment_data_2d_3d: Excessive i-direction halo size for the input structure.")
302 if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))&
303 & call mpp_error(fatal, "CT_increment_data_2d_3d: Excessive j-direction halo size for the input structure.")
304 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
305 & call mpp_error(fatal, "CT_increment_data_2d_3d: Excessive i-direction halo size for the output structure.")
306 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
307 & call mpp_error(fatal, "CT_increment_data_2d_3d: Excessive j-direction halo size for the output structure.")
308
309 if ((1+var%iec-var%isc) == size(weights,1)) then
310 iow = 1 - var%isc
311 elseif ((1+var%ied-var%isd) == size(weights,1)) then
312 iow = 1 - var%isd
313 elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then
314 iow = 1 + (var_in%isc - var_in%isd) - var%isc
315 else
316 call mpp_error(fatal, &
317 & "CT_increment_data_2d_3d: weights array must be the i-size of a computational or data domain.")
318 endif
319 if ((1+var%jec-var%jsc) == size(weights,2)) then
320 jow = 1 - var%jsc
321 elseif ((1+var%jed-var%jsd) == size(weights,2)) then
322 jow = 1 - var%jsd
323 elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then
324 jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc
325 else
326 call mpp_error(fatal, &
327 & "CT_increment_data_2d_3d: weights array must be the j-size of a computational or data domain.")
328 endif
329
330 io1 = var_in%isc - var%isc
331 jo1 = var_in%jsc - var%jsc
332 kow = 1 - var_in%ks
333 endif
334
335 do n = n1, n2
336 increment_bc = .true.
337 if (increment_bc .and. present(exclude_flux_type))&
338 & increment_bc = .not.(trim(var_in%FMS_CP_BC_TYPE_(n)%flux_type) == trim(exclude_flux_type))
339 if (increment_bc .and. present(only_flux_type))&
340 & increment_bc = (trim(var_in%FMS_CP_BC_TYPE_(n)%flux_type) == trim(only_flux_type))
341 if (increment_bc .and. present(pass_through_ice))&
342 & increment_bc = (pass_through_ice .eqv. var_in%FMS_CP_BC_TYPE_(n)%pass_through_ice)
343 if (.not.increment_bc) cycle
344
345 do m = 1, var_in%FMS_CP_BC_TYPE_(n)%num_fields
346 if (present(field_index)) then
347 if (m /= field_index) cycle
348 endif
349 if ( associated(var%FMS_CP_BC_TYPE_(n)%field(m)%values) ) then
350 do k=var_in%ks,var_in%ke
351 do j=var%jsc-halo,var%jec+halo
352 do i=var%isc-halo,var%iec+halo
353 var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j) = sc_prev * var%FMS_CP_BC_TYPE_(n)%field(m)%values(i,j) +&
354 & (scale * weights(i+iow,j+jow,k+kow)) * var_in%FMS_CP_BC_TYPE_(n)%field(m)%values(i+io1,j+io1,k)
355 enddo
356 enddo
357 enddo
358 endif
359 enddo
360 enddo
361 end subroutine ct_increment_data_2d_3d_
362
363 !> @brief Extract a 2d field from a coupler_2d_bc_type
364 !!
365 !! Extract a single 2-d field from a coupler_2d_bc_type into a two-dimensional array.
366 !!
367 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
368 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
369 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
370 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
371 !! @throw FATAL, "Disordered i-dimension index bound list"
372 !! @throw FATAL, "Disordered j-dimension index bound list"
373 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
374 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
375 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
376 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
377 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
378 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
379 subroutine ct_extract_data_2d_(var_in, bc_index, field_index, array_out,&
380 & scale_factor, halo_size, idim, jdim)
381 type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract
382 integer, intent(in) :: bc_index !< The index of the boundary condition
383 !! that is being copied
384 integer, intent(in) :: field_index !< The index of the field in the
385 !! boundary condition that is being copied
386 real(FMS_CP_KIND_), dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size
387 !! must match the size of the data being copied
388 !! unless idim and jdim are supplied.
389 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
390 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
391 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
392 !! the first dimension of the output array
393 !! in a non-decreasing list
394 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
395 !! the second dimension of the output array
396 !! in a non-decreasing list
397
398 character(len=*), parameter :: error_header =&
399 & '==>Error from coupler_types_mod (CT_extract_data_2d):'
400 character(len=400) :: error_msg
401
402 real(FMS_CP_KIND_) :: scale
403 integer :: i, j, halo, i_off, j_off
404 integer, parameter :: kindl = fms_cp_kind_
405
406 if (bc_index <= 0) then
407 array_out(:,:) = 0.0_kindl
408 return
409 endif
410
411 halo = 0
412 if (present(halo_size)) halo = halo_size
413 scale = 1.0_kindl
414 if (present(scale_factor)) scale = scale_factor
415
416 if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))&
417 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
418 if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))&
419 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
420
421 if (bc_index > var_in%num_bcs)&
422 & call mpp_error(fatal, trim(error_header)//" bc_index exceeds var_in%num_bcs.")
423 if (field_index > var_in%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
424 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
425 & trim(var_in%FMS_CP_BC_TYPE_(bc_index)%name) )
426
427 ! Do error checking on the i-dimension and determine the array offsets.
428 if (present(idim)) then
429 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
430 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
431 call mpp_error(fatal, trim(error_msg))
432 endif
433 if (size(array_out,1) /= (1+idim(4)-idim(1))) then
434 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
435 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1)
436 call mpp_error(fatal, trim(error_msg))
437 endif
438 if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))&
439 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
440 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
441 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
442 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
443 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
444 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
445 & (2*halo + 1 + var_in%iec - var_in%isc)
446 call mpp_error(fatal, trim(error_msg))
447 endif
448
449 i_off = (1-idim(1)) + (idim(2)-var_in%isc)
450 else
451 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
452 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
453 & size(array_out,1), ' does not match the data of size ',&
454 & (2*halo + 1 + var_in%iec - var_in%isc)
455 call mpp_error(fatal, trim(error_msg))
456 endif
457 i_off = 1 - (var_in%isc-halo)
458 endif
459
460 ! Do error checking on the j-dimension and determine the array offsets.
461 if (present(jdim)) then
462 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
463 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
464 call mpp_error(fatal, trim(error_msg))
465 endif
466 if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then
467 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
468 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2)
469 call mpp_error(fatal, trim(error_msg))
470 endif
471 if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))&
472 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
473 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
474 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
475 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
476 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
477 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
478 & (2*halo + 1 + var_in%jec - var_in%jsc)
479 call mpp_error(fatal, trim(error_msg))
480 endif
481
482 j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc)
483 else
484 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
485 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
486 & size(array_out,2), ' does not match the data of size ',&
487 & (2*halo + 1 + var_in%jec - var_in%jsc)
488 call mpp_error(fatal, trim(error_msg))
489 endif
490 j_off = 1 - (var_in%jsc-halo)
491 endif
492
493 do j=var_in%jsc-halo,var_in%jec+halo
494 do i=var_in%isc-halo,var_in%iec+halo
495 array_out(i+i_off,j+j_off) = scale * var_in%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j)
496 enddo
497 enddo
498 end subroutine ct_extract_data_2d_
499
500 !> @brief Extract a single k-level of a 3d field from a coupler_3d_bc_type
501 !!
502 !! Extract a single k-level of a 3-d field from a coupler_3d_bc_type into a two-dimensional array.
503 !!
504 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
505 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
506 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
507 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
508 !! @throw FATAL, "Disordered i-dimension index bound list"
509 !! @throw FATAL, "Disordered j-dimension index bound list"
510 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
511 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
512 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
513 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
514 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
515 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
516 !! @throw FATAL, "The extracted k-index of 'k' is outside of the valid range of 'ks' to 'ke'"
517 subroutine ct_extract_data_3d_2d_(var_in, bc_index, field_index, k_in, array_out,&
518 & scale_factor, halo_size, idim, jdim)
519 type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract
520 integer, intent(in) :: bc_index !< The index of the boundary condition
521 !! that is being copied
522 integer, intent(in) :: field_index !< The index of the field in the
523 !! boundary condition that is being copied
524 integer, intent(in) :: k_in !< The k-index to extract
525 real(FMS_CP_KIND_), dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size
526 !! must match the size of the data being copied
527 !! unless idim and jdim are supplied.
528 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
529 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
530 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
531 !! the first dimension of the output array
532 !! in a non-decreasing list
533 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
534 !! the second dimension of the output array
535 !! in a non-decreasing list
536 character(len=*), parameter :: error_header =&
537 & '==>Error from coupler_types_mod (CT_extract_data_3d_2d):'
538 character(len=400) :: error_msg
539
540 real(FMS_CP_KIND_) :: scale
541 integer :: i, j, halo, i_off, j_off
542 integer, parameter :: kindl = fms_cp_kind_
543
544 if (bc_index <= 0) then
545 array_out(:,:) = 0.0_kindl
546 return
547 endif
548
549 halo = 0
550 if (present(halo_size)) halo = halo_size
551 scale = 1.0_kindl
552 if (present(scale_factor)) scale = scale_factor
553
554 if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))&
555 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
556 if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))&
557 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
558
559 if (bc_index > var_in%num_bcs)&
560 & call mpp_error(fatal, trim(error_header)//" bc_index exceeds var_in%num_bcs.")
561 if (field_index > var_in%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
562 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
563 & trim(var_in%FMS_CP_BC_TYPE_(bc_index)%name) )
564
565 ! Do error checking on the i-dimension and determine the array offsets.
566 if (present(idim)) then
567 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
568 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
569 call mpp_error(fatal, trim(error_msg))
570 endif
571 if (size(array_out,1) /= (1+idim(4)-idim(1))) then
572 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
573 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1)
574 call mpp_error(fatal, trim(error_msg))
575 endif
576 if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))&
577 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
578 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
579 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
580 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
581 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
582 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
583 & (2*halo + 1 + var_in%iec - var_in%isc)
584 call mpp_error(fatal, trim(error_msg))
585 endif
586
587 i_off = (1-idim(1)) + (idim(2)-var_in%isc)
588 else
589 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
590 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
591 & size(array_out,1), ' does not match the data of size ',&
592 & (2*halo + 1 + var_in%iec - var_in%isc)
593 call mpp_error(fatal, trim(error_msg))
594 endif
595 i_off = 1 - (var_in%isc-halo)
596 endif
597
598 ! Do error checking on the j-dimension and determine the array offsets.
599 if (present(jdim)) then
600 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
601 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
602 call mpp_error(fatal, trim(error_msg))
603 endif
604 if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then
605 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
606 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2)
607 call mpp_error(fatal, trim(error_msg))
608 endif
609 if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))&
610 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
611 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
612 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
613 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
614 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
615 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
616 & (2*halo + 1 + var_in%jec - var_in%jsc)
617 call mpp_error(fatal, trim(error_msg))
618 endif
619
620 j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc)
621 else
622 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
623 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
624 & size(array_out,2), ' does not match the data of size ',&
625 & (2*halo + 1 + var_in%jec - var_in%jsc)
626 call mpp_error(fatal, trim(error_msg))
627 endif
628 j_off = 1 - (var_in%jsc-halo)
629 endif
630
631 if ((k_in > var_in%ke) .or. (k_in < var_in%ks)) then
632 write (error_msg, *) trim(error_header), ' The extracted k-index of ', k_in,&
633 & ' is outside of the valid range of ', var_in%ks, ' to ', var_in%ke
634 call mpp_error(fatal, trim(error_msg))
635 endif
636
637 do j=var_in%jsc-halo,var_in%jec+halo
638 do i=var_in%isc-halo,var_in%iec+halo
639 array_out(i+i_off,j+j_off) = scale * var_in%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j,k_in)
640 enddo
641 enddo
642 end subroutine ct_extract_data_3d_2d_
643
644 !> @brief Extract single 3d field from a coupler_3d_bc_type
645 !!
646 !! Extract a single 3-d field from a coupler_3d_bc_type into a three-dimensional array.
647 !!
648 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
649 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
650 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
651 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
652 !! @throw FATAL, "Disordered i-dimension index bound list"
653 !! @throw FATAL, "Disordered j-dimension index bound list"
654 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
655 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
656 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
657 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
658 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
659 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
660 !! @throw FATAL, "The target array with k-dimension size 'n' does not match the data of size 'd'"
661 subroutine ct_extract_data_3d_(var_in, bc_index, field_index, array_out,&
662 & scale_factor, halo_size, idim, jdim)
663 type(coupler_3d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract
664 integer, intent(in) :: bc_index !< The index of the boundary condition
665 !! that is being copied
666 integer, intent(in) :: field_index !< The index of the field in the
667 !! boundary condition that is being copied
668 real(FMS_CP_KIND_), dimension(1:,1:,1:), intent(out) :: array_out !< The recipient array for the field; its size
669 !! must match the size of the data being copied
670 !! unless idim and jdim are supplied.
671 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
672 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
673 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
674 !! the first dimension of the output array
675 !! in a non-decreasing list
676 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
677 !! the second dimension of the output array
678 !! in a non-decreasing list
679
680 character(len=*), parameter :: error_header =&
681 & '==>Error from coupler_types_mod (CT_extract_data_3d):'
682 character(len=400) :: error_msg
683
684 real(FMS_CP_KIND_) :: scale
685 integer :: i, j, k, halo, i_off, j_off, k_off
686 integer, parameter :: kindl = fms_cp_kind_
687
688 if (bc_index <= 0) then
689 array_out(:,:,:) = 0.0_kindl
690 return
691 endif
692
693 halo = 0
694 if (present(halo_size)) halo = halo_size
695 scale = 1.0_kindl
696 if (present(scale_factor)) scale = scale_factor
697
698 if ((var_in%isc-var_in%isd < halo) .or. (var_in%ied-var_in%iec < halo))&
699 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
700 if ((var_in%jsc-var_in%jsd < halo) .or. (var_in%jed-var_in%jec < halo))&
701 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
702
703 if (bc_index > var_in%num_bcs)&
704 & call mpp_error(fatal, trim(error_header)//" bc_index exceeds var_in%num_bcs.")
705 if (field_index > var_in%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
706 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
707 & trim(var_in%FMS_CP_BC_TYPE_(bc_index)%name) )
708
709 ! Do error checking on the i-dimension and determine the array offsets.
710 if (present(idim)) then
711 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
712 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
713 call mpp_error(fatal, trim(error_msg))
714 endif
715 if (size(array_out,1) /= (1+idim(4)-idim(1))) then
716 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
717 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_out,1)
718 call mpp_error(fatal, trim(error_msg))
719 endif
720 if ((var_in%iec-var_in%isc) /= (idim(3)-idim(2)))&
721 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
722 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
723 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
724 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
725 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
726 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
727 & (2*halo + 1 + var_in%iec - var_in%isc)
728 call mpp_error(fatal, trim(error_msg))
729 endif
730
731 i_off = (1-idim(1)) + (idim(2)-var_in%isc)
732 else
733 if (size(array_out,1) < 2*halo + 1 + var_in%iec - var_in%isc) then
734 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
735 & size(array_out,1), ' does not match the data of size ',&
736 & (2*halo + 1 + var_in%iec - var_in%isc)
737 call mpp_error(fatal, trim(error_msg))
738 endif
739 i_off = 1 - (var_in%isc-halo)
740 endif
741
742 ! Do error checking on the j-dimension and determine the array offsets.
743 if (present(jdim)) then
744 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
745 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
746 call mpp_error(fatal, trim(error_msg))
747 endif
748 if (size(array_out,2) /= (1+jdim(4)-jdim(1))) then
749 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
750 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_out,2)
751 call mpp_error(fatal, trim(error_msg))
752 endif
753 if ((var_in%jec-var_in%jsc) /= (jdim(3)-jdim(2)))&
754 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
755 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
756 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
757 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
758 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
759 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
760 & (2*halo + 1 + var_in%jec - var_in%jsc)
761 call mpp_error(fatal, trim(error_msg))
762 endif
763
764 j_off = (1-jdim(1)) + (jdim(2)-var_in%jsc)
765 else
766 if (size(array_out,2) < 2*halo + 1 + var_in%jec - var_in%jsc) then
767 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
768 & size(array_out,2), ' does not match the data of size ',&
769 & (2*halo + 1 + var_in%jec - var_in%jsc)
770 call mpp_error(fatal, trim(error_msg))
771 endif
772 j_off = 1 - (var_in%jsc-halo)
773 endif
774
775 if (size(array_out,3) /= 1 + var_in%ke - var_in%ks) then
776 write (error_msg, *) trim(error_header), ' The target array with k-dimension size ',&
777 & size(array_out,3), ' does not match the data of size ',&
778 & (1 + var_in%ke - var_in%ks)
779 call mpp_error(fatal, trim(error_msg))
780 endif
781 k_off = 1 - var_in%ks
782
783 do k=var_in%ks,var_in%ke
784 do j=var_in%jsc-halo,var_in%jec+halo
785 do i=var_in%isc-halo,var_in%iec+halo
786 array_out(i+i_off,j+j_off,k+k_off) = scale * var_in%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j,k)
787 enddo
788 enddo
789 enddo
790 end subroutine ct_extract_data_3d_
791
792 !> @brief Set single 2d field in coupler_3d_bc_type
793 !!
794 !! Set a single 2-d field in a coupler_3d_bc_type from a two-dimensional array.
795 !!
796 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
797 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
798 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
799 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
800 !! @throw FATAL, "Disordered i-dimension index bound list"
801 !! @throw FATAL, "Disordered j-dimension index bound list"
802 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
803 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
804 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
805 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
806 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
807 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
808 subroutine ct_set_data_2d_(array_in, bc_index, field_index, var,&
809 & scale_factor, halo_size, idim, jdim)
810 real(FMS_CP_KIND_), dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size
811 !! must match the size of the data being copied
812 !! unless idim and jdim are supplied.
813 integer, intent(in) :: bc_index !< The index of the boundary condition
814 !! that is being copied
815 integer, intent(in) :: field_index !< The index of the field in the
816 !! boundary condition that is being copied
817 type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set
818 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
819 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
820 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
821 !! the first dimension of the output array
822 !! in a non-decreasing list
823 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
824 !! the second dimension of the output array
825 !! in a non-decreasing list
826 character(len=*), parameter :: error_header =&
827 & '==>Error from coupler_types_mod (CT_set_data_2d):'
828 character(len=400) :: error_msg
829
830 real(FMS_CP_KIND_) :: scale
831 integer :: i, j, halo, i_off, j_off
832 integer, parameter :: kindl = fms_cp_kind_
833
834 if (bc_index <= 0) return
835
836 halo = 0
837 if (present(halo_size)) halo = halo_size
838 scale = 1.0_kindl
839 if (present(scale_factor)) scale = scale_factor
840
841 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
842 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
843 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
844 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
845
846 if (bc_index > var%num_bcs) &
847 call mpp_error(fatal, trim(error_header)//" bc_index exceeds var%num_bcs.")
848 if (field_index > var%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
849 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
850 & trim(var%FMS_CP_BC_TYPE_(bc_index)%name) )
851
852 ! Do error checking on the i-dimension and determine the array offsets.
853 if (present(idim)) then
854 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
855 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
856 call mpp_error(fatal, trim(error_msg))
857 endif
858 if (size(array_in,1) /= (1+idim(4)-idim(1))) then
859 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
860 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1)
861 call mpp_error(fatal, trim(error_msg))
862 endif
863 if ((var%iec-var%isc) /= (idim(3)-idim(2)))&
864 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
865 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
866 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
867 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
868 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
869 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
870 & (2*halo + 1 + var%iec - var%isc)
871 call mpp_error(fatal, trim(error_msg))
872 endif
873
874 i_off = (1-idim(1)) + (idim(2)-var%isc)
875 else
876 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
877 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
878 & size(array_in,1), ' does not match the data of size ',&
879 & (2*halo + 1 + var%iec - var%isc)
880 call mpp_error(fatal, trim(error_msg))
881 endif
882 i_off = 1 - (var%isc-halo)
883 endif
884
885 ! Do error checking on the j-dimension and determine the array offsets.
886 if (present(jdim)) then
887 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
888 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
889 call mpp_error(fatal, trim(error_msg))
890 endif
891 if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then
892 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
893 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2)
894 call mpp_error(fatal, trim(error_msg))
895 endif
896 if ((var%jec-var%jsc) /= (jdim(3)-jdim(2)))&
897 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
898 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
899 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
900 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
901 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
902 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
903 & (2*halo + 1 + var%jec - var%jsc)
904 call mpp_error(fatal, trim(error_msg))
905 endif
906
907 j_off = (1-jdim(1)) + (jdim(2)-var%jsc)
908 else
909 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
910 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
911 & size(array_in,2), ' does not match the data of size ',&
912 & (2*halo + 1 + var%jec - var%jsc)
913 call mpp_error(fatal, trim(error_msg))
914 endif
915 j_off = 1 - (var%jsc-halo)
916 endif
917
918 do j=var%jsc-halo,var%jec+halo
919 do i=var%isc-halo,var%iec+halo
920 var%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j) = scale * array_in(i+i_off,j+j_off)
921 enddo
922 enddo
923 end subroutine ct_set_data_2d_
924
925 !> @brief Set one k-level of a single 3d field in a coupler_3d_bc_type
926 !!
927 !! This subroutine sets a one k-level of a single 3-d field in a coupler_3d_bc_type from a
928 !! two-dimensional array.
929 !!
930 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
931 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
932 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
933 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
934 !! @throw FATAL, "Disordered i-dimension index bound list"
935 !! @throw FATAL, "Disordered j-dimension index bound list"
936 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
937 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
938 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
939 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
940 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
941 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
942 !! @throw FATAL, "The k-index of 'k' is outside of the valid range of 'ks' to 'ke'"
943 subroutine ct_set_data_2d_3d_(array_in, bc_index, field_index, k_out, var,&
944 & scale_factor, halo_size, idim, jdim)
945 real(FMS_CP_KIND_), dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size
946 !! must match the size of the data being copied
947 !! unless idim and jdim are supplied.
948 integer, intent(in) :: bc_index !< The index of the boundary condition
949 !! that is being copied
950 integer, intent(in) :: field_index !< The index of the field in the
951 !! boundary condition that is being copied
952 integer, intent(in) :: k_out !< The k-index to set
953 type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set
954 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
955 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
956 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
957 !! the first dimension of the output array
958 !! in a non-decreasing list
959 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
960 !! the second dimension of the output array
961 !! in a non-decreasing list
962
963 character(len=*), parameter :: error_header =&
964 & '==>Error from coupler_types_mod (CT_set_data_3d_2d):'
965 character(len=400) :: error_msg
966
967 real(FMS_CP_KIND_) :: scale
968 integer :: i, j, halo, i_off, j_off
969 integer, parameter :: kindl = fms_cp_kind_
970
971 if (bc_index <= 0) return
972
973 halo = 0
974 if (present(halo_size)) halo = halo_size
975 scale = 1.0_kindl
976 if (present(scale_factor)) scale = scale_factor
977
978 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
979 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
980 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
981 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
982
983 if (bc_index > var%num_bcs)&
984 & call mpp_error(fatal, trim(error_header)//" bc_index exceeds var%num_bcs.")
985 if (field_index > var%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
986 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
987 & trim(var%FMS_CP_BC_TYPE_(bc_index)%name) )
988
989 ! Do error checking on the i-dimension and determine the array offsets.
990 if (present(idim)) then
991 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
992 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
993 call mpp_error(fatal, trim(error_msg))
994 endif
995 if (size(array_in,1) /= (1+idim(4)-idim(1))) then
996 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
997 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1)
998 call mpp_error(fatal, trim(error_msg))
999 endif
1000 if ((var%iec-var%isc) /= (idim(3)-idim(2)))&
1001 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
1002 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
1003 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
1004 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
1005 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
1006 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
1007 & (2*halo + 1 + var%iec - var%isc)
1008 call mpp_error(fatal, trim(error_msg))
1009 endif
1010
1011 i_off = (1-idim(1)) + (idim(2)-var%isc)
1012 else
1013 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
1014 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
1015 & size(array_in,1), ' does not match the data of size ',&
1016 & (2*halo + 1 + var%iec - var%isc)
1017 call mpp_error(fatal, trim(error_msg))
1018 endif
1019 i_off = 1 - (var%isc-halo)
1020 endif
1021
1022 ! Do error checking on the j-dimension and determine the array offsets.
1023 if (present(jdim)) then
1024 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
1025 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
1026 call mpp_error(fatal, trim(error_msg))
1027 endif
1028 if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then
1029 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
1030 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2)
1031 call mpp_error(fatal, trim(error_msg))
1032 endif
1033 if ((var%jec-var%jsc) /= (jdim(3)-jdim(2)))&
1034 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
1035 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
1036 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
1037 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
1038 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
1039 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
1040 & (2*halo + 1 + var%jec - var%jsc)
1041 call mpp_error(fatal, trim(error_msg))
1042 endif
1043
1044 j_off = (1-jdim(1)) + (jdim(2)-var%jsc)
1045 else
1046 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
1047 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
1048 & size(array_in,2), ' does not match the data of size ',&
1049 & (2*halo + 1 + var%jec - var%jsc)
1050 call mpp_error(fatal, trim(error_msg))
1051 endif
1052 j_off = 1 - (var%jsc-halo)
1053 endif
1054
1055 if ((k_out > var%ke) .or. (k_out < var%ks)) then
1056 write (error_msg, *) trim(error_header), ' The k-index of ', k_out,&
1057 & ' is outside of the valid range of ', var%ks, ' to ', var%ke
1058 call mpp_error(fatal, trim(error_msg))
1059 endif
1060
1061 do j=var%jsc-halo,var%jec+halo
1062 do i=var%isc-halo,var%iec+halo
1063 var%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j,k_out) = scale * array_in(i+i_off,j+j_off)
1064 enddo
1065 enddo
1066 end subroutine ct_set_data_2d_3d_
1067
1068 !> @brief Set a single 3d field in a coupler_3d_bc_type
1069 !!
1070 !! This subroutine sets a single 3-d field in a coupler_3d_bc_type from a three-dimensional array.
1071 !!
1072 !! @throw FATAL, "bc_index is present and exceeds var_in%num_bcs."
1073 !! @throw FATAL, "field_index exceeds num_fields for var_in%FMS_CP_BC_TYPE_(bc_incdx)%name"
1074 !! @throw FATAL, "Excessive i-direction halo size for the input structure."
1075 !! @throw FATAL, "Excessive j-direction halo size for the input structure."
1076 !! @throw FATAL, "Disordered i-dimension index bound list"
1077 !! @throw FATAL, "Disordered j-dimension index bound list"
1078 !! @throw FATAL, "The declared i-dimension size of 'n' does not match the actual size of 'a'"
1079 !! @throw FATAL, "The declared j-dimension size of 'n' does not match the actual size of 'a'"
1080 !! @throw FATAL, "There is an i-direction computational domain size mismatch."
1081 !! @throw FATAL, "There is an j-direction computational domain size mismatch."
1082 !! @throw FATAL, "The target array with i-dimension size 'n' is too small to match the data of size 'd'"
1083 !! @throw FATAL, "The target array with j-dimension size 'n' is too small to match the data of size 'd'"
1084 !! @throw FATAL, "The target array with K-dimension size 'n' is too small to match the data of size 'd'"
1085 subroutine ct_set_data_3d_(array_in, bc_index, field_index, var,&
1086 & scale_factor, halo_size, idim, jdim)
1087 real(FMS_CP_KIND_), dimension(1:,1:,1:), intent(in) :: array_in !< The source array for the field; its size
1088 !! must match the size of the data being copied
1089 !! unless idim and jdim are supplied.
1090 integer, intent(in) :: bc_index !< The index of the boundary condition
1091 !! that is being copied
1092 integer, intent(in) :: field_index !< The index of the field in the
1093 !! boundary condition that is being copied
1094 type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure with the data to be set
1095 real(FMS_CP_KIND_), optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added
1096 integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default
1097 integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of
1098 !! the first dimension of the output array
1099 !! in a non-decreasing list
1100 integer, dimension(4), optional, intent(in) :: jdim !< The data and computational domain extents of
1101 !! the second dimension of the output array
1102 !! in a non-decreasing list
1103
1104 character(len=*), parameter :: error_header =&
1105 & '==>Error from coupler_types_mod (CT_set_data_3d):'
1106 character(len=400) :: error_msg
1107
1108 real(FMS_CP_KIND_) :: scale
1109 integer :: i, j, k, halo, i_off, j_off, k_off
1110 integer, parameter :: kindl = fms_cp_kind_
1111
1112 if (bc_index <= 0) return
1113
1114 halo = 0
1115 if (present(halo_size)) halo = halo_size
1116 scale = 1.0_kindl
1117 if (present(scale_factor)) scale = scale_factor
1118
1119 if ((var%isc-var%isd < halo) .or. (var%ied-var%iec < halo))&
1120 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the input structure.")
1121 if ((var%jsc-var%jsd < halo) .or. (var%jed-var%jec < halo))&
1122 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the input structure.")
1123
1124 if (bc_index > var%num_bcs)&
1125 & call mpp_error(fatal, trim(error_header)//" bc_index exceeds var%num_bcs.")
1126 if (field_index > var%FMS_CP_BC_TYPE_(bc_index)%num_fields)&
1127 & call mpp_error(fatal, trim(error_header)//" field_index exceeds num_fields for" //&
1128 & trim(var%FMS_CP_BC_TYPE_(bc_index)%name) )
1129
1130 ! Do error checking on the i-dimension and determine the array offsets.
1131 if (present(idim)) then
1132 if ((idim(1) > idim(2)) .or. (idim(3) > idim(4))) then
1133 write (error_msg, *) trim(error_header), ' Disordered i-dimension index bound list ', idim
1134 call mpp_error(fatal, trim(error_msg))
1135 endif
1136 if (size(array_in,1) /= (1+idim(4)-idim(1))) then
1137 write (error_msg, *) trim(error_header), ' The declared i-dimension size of ',&
1138 & (1+idim(4)-idim(1)), ' does not match the actual size of ', size(array_in,1)
1139 call mpp_error(fatal, trim(error_msg))
1140 endif
1141 if ((var%iec-var%isc) /= (idim(3)-idim(2)))&
1142 & call mpp_error(fatal, trim(error_header)//" There is an i-direction computational domain size mismatch.")
1143 if ((idim(2)-idim(1) < halo) .or. (idim(4)-idim(3) < halo))&
1144 & call mpp_error(fatal, trim(error_header)//" Excessive i-direction halo size for the output array.")
1145 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
1146 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
1147 & (1+idim(4)-idim(1)), ' is too small to match the data of size ',&
1148 & (2*halo + 1 + var%iec - var%isc)
1149 call mpp_error(fatal, trim(error_msg))
1150 endif
1151
1152 i_off = (1-idim(1)) + (idim(2)-var%isc)
1153 else
1154 if (size(array_in,1) < 2*halo + 1 + var%iec - var%isc) then
1155 write (error_msg, *) trim(error_header), ' The target array with i-dimension size ',&
1156 & size(array_in,1), ' does not match the data of size ',&
1157 & (2*halo + 1 + var%iec - var%isc)
1158 call mpp_error(fatal, trim(error_msg))
1159 endif
1160 i_off = 1 - (var%isc-halo)
1161 endif
1162
1163 ! Do error checking on the j-dimension and determine the array offsets.
1164 if (present(jdim)) then
1165 if ((jdim(1) > jdim(2)) .or. (jdim(3) > jdim(4))) then
1166 write (error_msg, *) trim(error_header), ' Disordered j-dimension index bound list ', jdim
1167 call mpp_error(fatal, trim(error_msg))
1168 endif
1169 if (size(array_in,2) /= (1+jdim(4)-jdim(1))) then
1170 write (error_msg, *) trim(error_header), ' The declared j-dimension size of ',&
1171 & (1+jdim(4)-jdim(1)), ' does not match the actual size of ', size(array_in,2)
1172 call mpp_error(fatal, trim(error_msg))
1173 endif
1174 if ((var%jec-var%jsc) /= (jdim(3)-jdim(2)))&
1175 & call mpp_error(fatal, trim(error_header)//" There is an j-direction computational domain size mismatch.")
1176 if ((jdim(2)-jdim(1) < halo) .or. (jdim(4)-jdim(3) < halo))&
1177 & call mpp_error(fatal, trim(error_header)//" Excessive j-direction halo size for the output array.")
1178 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
1179 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
1180 & (1+jdim(4)-jdim(1)), ' is too small to match the data of size ',&
1181 & (2*halo + 1 + var%jec - var%jsc)
1182 call mpp_error(fatal, trim(error_msg))
1183 endif
1184
1185 j_off = (1-jdim(1)) + (jdim(2)-var%jsc)
1186 else
1187 if (size(array_in,2) < 2*halo + 1 + var%jec - var%jsc) then
1188 write (error_msg, *) trim(error_header), ' The target array with j-dimension size ',&
1189 & size(array_in,2), ' does not match the data of size ',&
1190 & (2*halo + 1 + var%jec - var%jsc)
1191 call mpp_error(fatal, trim(error_msg))
1192 endif
1193 j_off = 1 - (var%jsc-halo)
1194 endif
1195
1196 if (size(array_in,3) /= 1 + var%ke - var%ks) then
1197 write (error_msg, *) trim(error_header), ' The target array with k-dimension size ',&
1198 & size(array_in,3), ' does not match the data of size ',&
1199 & (1 + var%ke - var%ks)
1200 call mpp_error(fatal, trim(error_msg))
1201 endif
1202 k_off = 1 - var%ks
1203
1204 do k=var%ks,var%ke
1205 do j=var%jsc-halo,var%jec+halo
1206 do i=var%isc-halo,var%iec+halo
1207 var%FMS_CP_BC_TYPE_(bc_index)%field(field_index)%values(i,j,k) = scale * array_in(i+i_off,j+j_off,k+k_off)
1208 enddo
1209 enddo
1210 enddo
1211 end subroutine ct_set_data_3d_
ct_extract_data_2d_
subroutine ct_extract_data_2d_(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim)
Extract a 2d field from a coupler_2d_bc_type.
Definition coupler_types.inc:381
ct_rescale_data_2d_
subroutine ct_rescale_data_2d_(var, scale, halo_size, bc_index, field_index, exclude_flux_type, only_flux_type, pass_through_ice)
Rescales the fields in the fields in the elements of a coupler_2d_bc_type.
Definition coupler_types.inc:36
ct_set_data_3d_
subroutine ct_set_data_3d_(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim)
Set a single 3d field in a coupler_3d_bc_type.
Definition coupler_types.inc:1087
ct_extract_data_3d_2d_
subroutine ct_extract_data_3d_2d_(var_in, bc_index, field_index, k_in, array_out, scale_factor, halo_size, idim, jdim)
Extract a single k-level of a 3d field from a coupler_3d_bc_type.
Definition coupler_types.inc:519
ct_set_data_2d_3d_
subroutine ct_set_data_2d_3d_(array_in, bc_index, field_index, k_out, var, scale_factor, halo_size, idim, jdim)
Set one k-level of a single 3d field in a coupler_3d_bc_type.
Definition coupler_types.inc:945
ct_rescale_data_3d_
subroutine ct_rescale_data_3d_(var, scale, halo_size, bc_index, field_index, exclude_flux_type, only_flux_type, pass_through_ice)
Rescales the fields in the elements of a coupler_3d_bc_type.
Definition coupler_types.inc:127
ct_increment_data_2d_3d_
subroutine ct_increment_data_2d_3d_(var_in, weights, var, halo_size, bc_index, field_index, scale_factor, scale_prev, exclude_flux_type, only_flux_type, pass_through_ice)
Increment data in the elements of a coupler_2d_bc_type with weighted averages of elements of a couple...
Definition coupler_types.inc:235
ct_extract_data_3d_
subroutine ct_extract_data_3d_(var_in, bc_index, field_index, array_out, scale_factor, halo_size, idim, jdim)
Extract single 3d field from a coupler_3d_bc_type.
Definition coupler_types.inc:663
ct_set_data_2d_
subroutine ct_set_data_2d_(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim)
Set single 2d field in coupler_3d_bc_type.
Definition coupler_types.inc:810