10 use mom_cpu_clock,
only : cpu_clock_id, cpu_clock_begin, cpu_clock_end
16 use mom_io,
only : get_filename_appendix
26 use mom_diag_remap,
only : diag_remap_init, diag_remap_end, diag_remap_do_remap
27 use mom_diag_remap,
only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field
28 use mom_diag_remap,
only : diag_remap_configure_axes, diag_remap_axes_configured
29 use mom_diag_remap,
only : diag_remap_get_axes_info, diag_remap_set_active
33 use diag_axis_mod,
only : get_diag_axis_name
34 use diag_data_mod,
only : null_axis_id
35 use diag_manager_mod,
only : diag_manager_init, diag_manager_end
36 use diag_manager_mod,
only : send_data, diag_axis_init, diag_field_add_attribute
40 use diag_manager_mod,
only : register_static_field_fms=>register_static_field
41 use diag_manager_mod,
only : get_diag_field_id_fms=>get_diag_field_id
42 use diag_manager_mod,
only : diag_field_not_found
44 implicit none ;
private
46 #undef __DO_SAFETY_CHECKS__
47 #define IMPLIES(A, B) ((.not. (A)) .or. (B))
48 #define MAX_DSAMP_LEV 2
50 public set_axes_info,
post_data, register_diag_field, time_type
51 public set_masks_for_axes
54 public enable_averaging, disable_averaging, query_averaging_enabled
55 public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid
56 public diag_mediator_infrastructure_init
57 public diag_mediator_close_registration, get_diag_time_end
58 public diag_axis_init, ocean_register_diag, register_static_field
59 public register_scalar_field
60 public define_axes_group, diag_masks_set
61 public diag_register_area_ids
62 public register_cell_measure, diag_associate_volume_cell_measure
63 public diag_get_volume_cell_measure_dm_id
64 public diag_set_state_ptrs, diag_update_remap_grids
65 public diag_grid_storage_init, diag_grid_storage_end
66 public diag_copy_diag_to_storage, diag_copy_storage_to_diag
67 public diag_save_grids, diag_restore_grids
71 module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d
76 module procedure downsample_field_2d, downsample_field_3d
81 module procedure downsample_mask_2d, downsample_mask_3d
86 module procedure downsample_diag_field_2d, downsample_diag_field_3d
91 real,
pointer,
dimension(:,:) :: mask2d => null()
92 real,
pointer,
dimension(:,:,:) :: mask3d => null()
97 character(len=15) :: id
99 integer,
dimension(:),
allocatable :: handles
103 character(len=9) :: x_cell_method =
''
105 character(len=9) :: y_cell_method =
''
107 character(len=9) :: v_cell_method =
''
111 integer :: vertical_coordinate_number = 0
113 logical :: is_h_point = .false.
114 logical :: is_q_point = .false.
115 logical :: is_u_point = .false.
116 logical :: is_v_point = .false.
117 logical :: is_layer = .false.
118 logical :: is_interface = .false.
120 logical :: is_native = .true.
122 logical :: needs_remapping = .false.
124 logical :: needs_interpolating = .false.
127 integer :: downsample_level = 1
131 integer :: id_area = -1
132 integer :: id_volume = -1
135 real,
pointer,
dimension(:,:) :: mask2d => null()
136 real,
pointer,
dimension(:,:,:) :: mask3d => null()
142 real,
dimension(:,:,:),
allocatable :: h
147 integer :: num_diag_coords
148 real,
dimension(:,:,:),
allocatable :: h_state
181 integer :: fms_diag_id
182 integer :: fms_xyave_diag_id = -1
183 integer :: downsample_diag_id = -1
184 character(64) :: debug_str =
''
187 real :: conversion_factor = 0.
188 logical :: v_extensive = .false.
190 integer :: xyz_method = 0
217 type(
axes_grp),
dimension(:),
allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
218 type(
axes_grp),
dimension(:),
allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
221 real,
dimension(:,:),
pointer :: mask2dt => null()
222 real,
dimension(:,:),
pointer :: mask2dbu => null()
223 real,
dimension(:,:),
pointer :: mask2dcu => null()
224 real,
dimension(:,:),
pointer :: mask2dcv => null()
226 real,
dimension(:,:,:),
pointer :: mask3dtl => null()
227 real,
dimension(:,:,:),
pointer :: mask3dbl => null()
228 real,
dimension(:,:,:),
pointer :: mask3dcul => null()
229 real,
dimension(:,:,:),
pointer :: mask3dcvl => null()
230 real,
dimension(:,:,:),
pointer :: mask3dti => null()
231 real,
dimension(:,:,:),
pointer :: mask3dbi => null()
232 real,
dimension(:,:,:),
pointer :: mask3dcui => null()
233 real,
dimension(:,:,:),
pointer :: mask3dcvi => null()
240 integer :: available_diag_doc_unit = -1
242 integer :: chksum_iounit = -1
244 logical :: diag_as_chksum
258 type(time_type) :: time_end
260 logical :: ave_enabled = .false.
272 real,
dimension(:,:),
pointer :: mask2dt => null()
273 real,
dimension(:,:),
pointer :: mask2dbu => null()
274 real,
dimension(:,:),
pointer :: mask2dcu => null()
275 real,
dimension(:,:),
pointer :: mask2dcv => null()
277 real,
dimension(:,:,:),
pointer :: mask3dtl => null()
278 real,
dimension(:,:,:),
pointer :: mask3dbl => null()
279 real,
dimension(:,:,:),
pointer :: mask3dcul => null()
280 real,
dimension(:,:,:),
pointer :: mask3dcvl => null()
281 real,
dimension(:,:,:),
pointer :: mask3dti => null()
282 real,
dimension(:,:,:),
pointer :: mask3dbi => null()
283 real,
dimension(:,:,:),
pointer :: mask3dcui => null()
284 real,
dimension(:,:,:),
pointer :: mask3dcvi => null()
292 #define DIAG_ALLOC_CHUNK_SIZE 100
294 integer :: next_free_diag_id
297 real :: missing_value = -1.0e+34
300 integer :: num_diag_coords
304 logical :: diag_grid_overridden = .false.
307 remap_axeszl, & !< The 1-D z-space cell-centered axis for remapping
310 type(
axes_grp),
dimension(:),
allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
311 type(
axes_grp),
dimension(:),
allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
315 real,
dimension(:,:,:),
pointer :: h => null()
316 real,
dimension(:,:,:),
pointer :: t => null()
317 real,
dimension(:,:,:),
pointer :: s => null()
324 integer :: volume_cell_measure_dm_id = -1
326 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
329 real,
dimension(:,:,:),
allocatable :: h_old
333 integer :: num_chksum_diags
338 integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates
343 subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
348 type(
diag_ctrl),
intent(inout) :: diag_cs
349 logical,
optional,
intent(in) :: set_vertical
352 integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
353 integer :: id_zl_native, id_zi_native
354 integer :: i, j, k, nz
355 real :: zlev(gv%ke), zinter(gv%ke+1)
358 set_vert = .true. ;
if (
present(set_vertical)) set_vert = set_vertical
361 if (g%symmetric)
then
362 id_xq = diag_axis_init(
'xq', g%gridLonB(g%isgB:g%iegB), g%x_axis_units,
'x', &
363 'q point nominal longitude', domain2=g%Domain%mpp_domain)
364 id_yq = diag_axis_init(
'yq', g%gridLatB(g%jsgB:g%jegB), g%y_axis_units,
'y', &
365 'q point nominal latitude', domain2=g%Domain%mpp_domain)
367 id_xq = diag_axis_init(
'xq', g%gridLonB(g%isg:g%ieg), g%x_axis_units,
'x', &
368 'q point nominal longitude', domain2=g%Domain%mpp_domain)
369 id_yq = diag_axis_init(
'yq', g%gridLatB(g%jsg:g%jeg), g%y_axis_units,
'y', &
370 'q point nominal latitude', domain2=g%Domain%mpp_domain)
372 id_xh = diag_axis_init(
'xh', g%gridLonT(g%isg:g%ieg), g%x_axis_units,
'x', &
373 'h point nominal longitude', domain2=g%Domain%mpp_domain)
374 id_yh = diag_axis_init(
'yh', g%gridLatT(g%jsg:g%jeg), g%y_axis_units,
'y', &
375 'h point nominal latitude', domain2=g%Domain%mpp_domain)
379 zinter(1:nz+1) = gv%sInterface(1:nz+1)
380 zlev(1:nz) = gv%sLayer(1:nz)
381 id_zl = diag_axis_init(
'zl', zlev, trim(gv%zAxisUnits),
'z', &
382 'Layer '//trim(gv%zAxisLongName), &
383 direction=gv%direction)
384 id_zi = diag_axis_init(
'zi', zinter, trim(gv%zAxisUnits),
'z', &
385 'Interface '//trim(gv%zAxisLongName), &
386 direction=gv%direction)
388 id_zl = -1 ; id_zi = -1
390 id_zl_native = id_zl ; id_zi_native = id_zi
392 call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, &
393 v_cell_method=
'point', is_interface=.true.)
394 call define_axes_group(diag_cs, (/ id_zl /), diag_cs%axesZL, &
395 v_cell_method=
'mean', is_layer=.true.)
398 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%axesTL, &
399 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
400 is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
401 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%axesBL, &
402 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
403 is_q_point=.true., is_layer=.true.)
404 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%axesCuL, &
405 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
406 is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
407 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%axesCvL, &
408 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
409 is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
412 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%axesTi, &
413 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
414 is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
415 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%axesBi, &
416 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
417 is_q_point=.true., is_interface=.true.)
418 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%axesCui, &
419 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
420 is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
421 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%axesCvi, &
422 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
423 is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
426 call define_axes_group(diag_cs, (/ id_xh, id_yh /), diag_cs%axesT1, &
427 x_cell_method=
'mean', y_cell_method=
'mean', is_h_point=.true.)
428 call define_axes_group(diag_cs, (/ id_xq, id_yq /), diag_cs%axesB1, &
429 x_cell_method=
'point', y_cell_method=
'point', is_q_point=.true.)
430 call define_axes_group(diag_cs, (/ id_xq, id_yh /), diag_cs%axesCu1, &
431 x_cell_method=
'point', y_cell_method=
'mean', is_u_point=.true.)
432 call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, &
433 x_cell_method=
'mean', y_cell_method=
'point', is_v_point=.true.)
436 call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull)
440 if (diag_cs%num_diag_coords>0)
then
441 allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords))
442 allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords))
443 allocate(diag_cs%remap_axesBL(diag_cs%num_diag_coords))
444 allocate(diag_cs%remap_axesCuL(diag_cs%num_diag_coords))
445 allocate(diag_cs%remap_axesCvL(diag_cs%num_diag_coords))
446 allocate(diag_cs%remap_axesZi(diag_cs%num_diag_coords))
447 allocate(diag_cs%remap_axesTi(diag_cs%num_diag_coords))
448 allocate(diag_cs%remap_axesBi(diag_cs%num_diag_coords))
449 allocate(diag_cs%remap_axesCui(diag_cs%num_diag_coords))
450 allocate(diag_cs%remap_axesCvi(diag_cs%num_diag_coords))
453 do i=1, diag_cs%num_diag_coords
455 call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), gv, us, param_file)
458 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i)))
then
462 call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
465 call define_axes_group(diag_cs, (/ id_zl /), diag_cs%remap_axesZL(i), &
466 nz=nz, vertical_coordinate_number=i, &
467 v_cell_method=
'mean', &
468 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.)
469 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%remap_axesTL(i), &
470 nz=nz, vertical_coordinate_number=i, &
471 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
472 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
473 xyave_axes=diag_cs%remap_axesZL(i))
477 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%remap_axesBL(i), &
478 nz=nz, vertical_coordinate_number=i, &
479 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
480 is_q_point=.true., is_layer=.true., is_native=.false.)
482 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%remap_axesCuL(i), &
483 nz=nz, vertical_coordinate_number=i, &
484 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
485 is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
486 xyave_axes=diag_cs%remap_axesZL(i))
488 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%remap_axesCvL(i), &
489 nz=nz, vertical_coordinate_number=i, &
490 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
491 is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
492 xyave_axes=diag_cs%remap_axesZL(i))
495 call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i), &
496 nz=nz, vertical_coordinate_number=i, &
497 v_cell_method=
'point', &
498 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.)
499 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%remap_axesTi(i), &
500 nz=nz, vertical_coordinate_number=i, &
501 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
502 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
503 xyave_axes=diag_cs%remap_axesZi(i))
506 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%remap_axesBi(i), &
507 nz=nz, vertical_coordinate_number=i, &
508 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
509 is_q_point=.true., is_interface=.true., is_native=.false.)
511 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%remap_axesCui(i), &
512 nz=nz, vertical_coordinate_number=i, &
513 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
514 is_u_point=.true., is_interface=.true., is_native=.false., &
515 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
517 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%remap_axesCvi(i), &
518 nz=nz, vertical_coordinate_number=i, &
519 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
520 is_v_point=.true., is_interface=.true., is_native=.false., &
521 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
526 call set_axes_info_dsamp(g, gv, param_file, diag_cs, id_zl_native, id_zi_native)
528 call diag_grid_storage_init(diag_cs%diag_grid_temp, g, diag_cs)
530 end subroutine set_axes_info
532 subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native)
536 type(
diag_ctrl),
intent(inout) :: diag_cs
537 integer,
intent(in) :: id_zl_native
538 integer,
intent(in) :: id_zi_native
541 integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
542 integer :: i, j, k, nz, dl
543 real,
dimension(:),
pointer :: gridLonT_dsamp =>null()
544 real,
dimension(:),
pointer :: gridLatT_dsamp =>null()
545 real,
dimension(:),
pointer :: gridLonB_dsamp =>null()
546 real,
dimension(:),
pointer :: gridLatB_dsamp =>null()
548 id_zl = id_zl_native ; id_zi = id_zi_native
550 do dl=2,max_dsamp_lev
551 if(dl .ne. 2)
call mom_error(fatal,
"set_axes_info_dsamp: Downsample level other than 2 is not supported yet!")
552 if (g%symmetric)
then
553 allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB))
554 allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB))
555 do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridlonb_dsamp(i) = g%gridLonB(g%isgB+dl*i);
enddo
556 do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridlatb_dsamp(j) = g%gridLatB(g%jsgB+dl*j);
enddo
557 id_xq = diag_axis_init(
'xq', gridlonb_dsamp, g%x_axis_units,
'x', &
558 'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
559 id_yq = diag_axis_init(
'yq', gridlatb_dsamp, g%y_axis_units,
'y', &
560 'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
561 deallocate(gridlonb_dsamp,gridlatb_dsamp)
563 allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
564 allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
565 do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlonb_dsamp(i) = g%gridLonB(g%isg+dl*i-2);
enddo
566 do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatb_dsamp(j) = g%gridLatB(g%jsg+dl*j-2);
enddo
567 id_xq = diag_axis_init(
'xq', gridlonb_dsamp, g%x_axis_units,
'x', &
568 'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
569 id_yq = diag_axis_init(
'yq', gridlatb_dsamp, g%y_axis_units,
'y', &
570 'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
571 deallocate(gridlonb_dsamp,gridlatb_dsamp)
574 allocate(gridlont_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
575 allocate(gridlatt_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
576 do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlont_dsamp(i) = g%gridLonT(g%isg+dl*i-2);
enddo
577 do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatt_dsamp(j) = g%gridLatT(g%jsg+dl*j-2);
enddo
578 id_xh = diag_axis_init(
'xh', gridlont_dsamp, g%x_axis_units,
'x', &
579 'h point nominal longitude', domain2=g%Domain%mpp_domain_d2)
580 id_yh = diag_axis_init(
'yh', gridlatt_dsamp, g%y_axis_units,
'y', &
581 'h point nominal latitude', domain2=g%Domain%mpp_domain_d2)
583 deallocate(gridlont_dsamp,gridlatt_dsamp)
586 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%axesTL, dl, &
587 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
588 is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
589 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%axesBL, dl, &
590 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
591 is_q_point=.true., is_layer=.true.)
592 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%axesCuL, dl, &
593 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
594 is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
595 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%axesCvL, dl, &
596 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
597 is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
600 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, &
601 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
602 is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
603 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, &
604 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
605 is_q_point=.true., is_interface=.true.)
606 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, &
607 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
608 is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
609 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, &
610 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
611 is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
614 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, &
615 x_cell_method=
'mean', y_cell_method=
'mean', is_h_point=.true.)
616 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, &
617 x_cell_method=
'point', y_cell_method=
'point', is_q_point=.true.)
618 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, &
619 x_cell_method=
'point', y_cell_method=
'mean', is_u_point=.true.)
620 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, &
621 x_cell_method=
'mean', y_cell_method=
'point', is_v_point=.true.)
624 if (diag_cs%num_diag_coords>0)
then
625 allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords))
626 allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords))
627 allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords))
628 allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords))
629 allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords))
630 allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords))
631 allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords))
632 allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords))
635 do i=1, diag_cs%num_diag_coords
640 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i)))
then
644 call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
647 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, &
648 nz=nz, vertical_coordinate_number=i, &
649 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
650 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
651 xyave_axes=diag_cs%remap_axesZL(i))
655 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, &
656 nz=nz, vertical_coordinate_number=i, &
657 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
658 is_q_point=.true., is_layer=.true., is_native=.false.)
660 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, &
661 nz=nz, vertical_coordinate_number=i, &
662 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
663 is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
664 xyave_axes=diag_cs%remap_axesZL(i))
666 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, &
667 nz=nz, vertical_coordinate_number=i, &
668 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
669 is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
670 xyave_axes=diag_cs%remap_axesZL(i))
673 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, &
674 nz=nz, vertical_coordinate_number=i, &
675 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
676 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
677 xyave_axes=diag_cs%remap_axesZi(i))
680 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, &
681 nz=nz, vertical_coordinate_number=i, &
682 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
683 is_q_point=.true., is_interface=.true., is_native=.false.)
685 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, &
686 nz=nz, vertical_coordinate_number=i, &
687 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
688 is_u_point=.true., is_interface=.true., is_native=.false., &
689 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
691 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, &
692 nz=nz, vertical_coordinate_number=i, &
693 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
694 is_v_point=.true., is_interface=.true., is_native=.false., &
695 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
700 end subroutine set_axes_info_dsamp
705 subroutine set_masks_for_axes(G, diag_cs)
710 integer :: c, nk, i, j, k, ii, jj
711 type(
axes_grp),
pointer :: axes => null(), h_axes => null()
713 do c=1, diag_cs%num_diag_coords
715 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(c)))
then
718 axes => diag_cs%remap_axesTL(c)
720 allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
721 call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), g, axes%mask3d)
723 h_axes => diag_cs%remap_axesTL(c)
726 axes => diag_cs%remap_axesCuL(c)
727 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at u-layers')
728 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
729 allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
730 do k = 1, nk ;
do j=g%jsc,g%jec ;
do i=g%isc-1,g%iec
731 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
732 enddo ;
enddo ;
enddo
735 axes => diag_cs%remap_axesCvL(c)
736 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at v-layers')
737 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
738 allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
739 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc,g%iec
740 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
741 enddo ;
enddo ;
enddo
744 axes => diag_cs%remap_axesBL(c)
745 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at q-layers')
746 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
747 allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
748 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc-1,g%iec
749 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
750 h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
751 enddo ;
enddo ;
enddo
754 axes => diag_cs%remap_axesTi(c)
755 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at h-interfaces')
756 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
757 allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
758 do j=g%jsc-1,g%jec+1 ;
do i=g%isc-1,g%iec+1
759 if (h_axes%mask3d(i,j,1) > 0.) axes%mask3d(i,j,1) = 1.
761 if (h_axes%mask3d(i,j,k-1) + h_axes%mask3d(i,j,k) > 0.) axes%mask3d(i,j,k) = 1.
763 if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,j,nk+1) = 1.
766 h_axes => diag_cs%remap_axesTi(c)
769 axes => diag_cs%remap_axesCui(c)
770 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at u-interfaces')
771 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
772 allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
773 do k = 1, nk+1 ;
do j=g%jsc,g%jec ;
do i=g%isc-1,g%iec
774 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
775 enddo ;
enddo ;
enddo
778 axes => diag_cs%remap_axesCvi(c)
779 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at v-interfaces')
780 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
781 allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
782 do k = 1, nk+1 ;
do j=g%jsc-1,g%jec ;
do i=g%isc,g%iec
783 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
784 enddo ;
enddo ;
enddo
787 axes => diag_cs%remap_axesBi(c)
788 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at q-interfaces')
789 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
790 allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
791 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc-1,g%iec
792 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
793 h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
794 enddo ;
enddo ;
enddo
799 call set_masks_for_axes_dsamp(g, diag_cs)
801 end subroutine set_masks_for_axes
803 subroutine set_masks_for_axes_dsamp(G, diag_cs)
808 integer :: c, nk, i, j, k, ii, jj
810 type(
axes_grp),
pointer :: axes => null(), h_axes => null()
815 do dl=2,max_dsamp_lev
816 if(dl .ne. 2)
call mom_error(fatal,
"set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!")
817 do c=1, diag_cs%num_diag_coords
819 axes => diag_cs%remap_axesTL(c)
820 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
821 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
822 diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d
824 axes => diag_cs%remap_axesCuL(c)
825 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
826 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
827 diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d
829 axes => diag_cs%remap_axesCvL(c)
830 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
831 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
832 diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d
834 axes => diag_cs%remap_axesBL(c)
835 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
836 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
837 diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d
839 axes => diag_cs%remap_axesTi(c)
840 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
841 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
842 diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d
844 axes => diag_cs%remap_axesCui(c)
845 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
846 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
847 diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d
849 axes => diag_cs%remap_axesCvi(c)
850 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
851 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
852 diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d
854 axes => diag_cs%remap_axesBi(c)
855 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
856 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
857 diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d
860 end subroutine set_masks_for_axes_dsamp
863 subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q)
865 integer,
optional,
intent(in) :: id_area_t
866 integer,
optional,
intent(in) :: id_area_q
869 if (
present(id_area_t))
then
870 fms_id = diag_cs%diags(id_area_t)%fms_diag_id
871 diag_cs%axesT1%id_area = fms_id
872 diag_cs%axesTi%id_area = fms_id
873 diag_cs%axesTL%id_area = fms_id
874 do i=1, diag_cs%num_diag_coords
875 diag_cs%remap_axesTL(i)%id_area = fms_id
876 diag_cs%remap_axesTi(i)%id_area = fms_id
879 if (
present(id_area_q))
then
880 fms_id = diag_cs%diags(id_area_q)%fms_diag_id
881 diag_cs%axesB1%id_area = fms_id
882 diag_cs%axesBi%id_area = fms_id
883 diag_cs%axesBL%id_area = fms_id
884 do i=1, diag_cs%num_diag_coords
885 diag_cs%remap_axesBL(i)%id_area = fms_id
886 diag_cs%remap_axesBi(i)%id_area = fms_id
889 end subroutine diag_register_area_ids
892 subroutine register_cell_measure(G, diag, Time)
894 type(
diag_ctrl),
target,
intent(inout) :: diag
895 type(time_type),
intent(in) :: time
898 id = register_diag_field(
'ocean_model',
'volcello', diag%axesTL, &
899 time,
'Ocean grid-cell volume',
'm3', &
900 standard_name=
'ocean_volume', v_extensive=.true., &
901 x_cell_method=
'sum', y_cell_method=
'sum')
902 call diag_associate_volume_cell_measure(diag, id)
904 end subroutine register_cell_measure
907 subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume)
909 integer,
intent(in) :: id_h_volume
911 type(
diag_type),
pointer :: tmp => null()
913 if (id_h_volume<=0)
return
914 diag_cs%volume_cell_measure_dm_id = id_h_volume
917 diag_cs%diags(id_h_volume)%axes%id_volume = diag_cs%diags(id_h_volume)%fms_diag_id
919 tmp => diag_cs%diags(id_h_volume)%next
920 do while (
associated(tmp))
922 tmp%axes%id_volume = tmp%fms_diag_id
926 end subroutine diag_associate_volume_cell_measure
929 integer function diag_get_volume_cell_measure_dm_id(diag_cs)
932 diag_get_volume_cell_measure_dm_id = diag_cs%volume_cell_measure_dm_id
934 end function diag_get_volume_cell_measure_dm_id
937 subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, &
938 x_cell_method, y_cell_method, v_cell_method, &
939 is_h_point, is_q_point, is_u_point, is_v_point, &
940 is_layer, is_interface, &
941 is_native, needs_remapping, needs_interpolating, &
944 integer,
dimension(:),
intent(in) :: handles
946 integer,
optional,
intent(in) :: nz
947 integer,
optional,
intent(in) :: vertical_coordinate_number
948 character(len=*),
optional,
intent(in) :: x_cell_method
950 character(len=*),
optional,
intent(in) :: y_cell_method
952 character(len=*),
optional,
intent(in) :: v_cell_method
954 logical,
optional,
intent(in) :: is_h_point
956 logical,
optional,
intent(in) :: is_q_point
958 logical,
optional,
intent(in) :: is_u_point
960 logical,
optional,
intent(in) :: is_v_point
962 logical,
optional,
intent(in) :: is_layer
964 logical,
optional,
intent(in) :: is_interface
966 logical,
optional,
intent(in) :: is_native
968 logical,
optional,
intent(in) :: needs_remapping
971 logical,
optional,
intent(in) :: needs_interpolating
974 type(
axes_grp),
optional,
target :: xyave_axes
980 if (n<1 .or. n>3)
call mom_error(fatal,
"define_axes_group: wrong size for list of handles!")
981 allocate( axes%handles(n) )
982 axes%id = i2s(handles, n)
984 axes%handles(:) = handles(:)
985 axes%diag_cs => diag_cs
986 if (
present(x_cell_method))
then
987 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
988 'Can not set x_cell_method for rank<2.')
989 axes%x_cell_method = trim(x_cell_method)
991 axes%x_cell_method =
''
993 if (
present(y_cell_method))
then
994 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
995 'Can not set y_cell_method for rank<2.')
996 axes%y_cell_method = trim(y_cell_method)
998 axes%y_cell_method =
''
1000 if (
present(v_cell_method))
then
1001 if (axes%rank/=1 .and. axes%rank/=3)
call mom_error(fatal,
'define_axes_group: ' // &
1002 'Can not set v_cell_method for rank<>1 or 3.')
1003 axes%v_cell_method = trim(v_cell_method)
1005 axes%v_cell_method =
''
1007 if (
present(nz)) axes%nz = nz
1008 if (
present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1009 if (
present(is_h_point)) axes%is_h_point = is_h_point
1010 if (
present(is_q_point)) axes%is_q_point = is_q_point
1011 if (
present(is_u_point)) axes%is_u_point = is_u_point
1012 if (
present(is_v_point)) axes%is_v_point = is_v_point
1013 if (
present(is_layer)) axes%is_layer = is_layer
1014 if (
present(is_interface)) axes%is_interface = is_interface
1015 if (
present(is_native)) axes%is_native = is_native
1016 if (
present(needs_remapping)) axes%needs_remapping = needs_remapping
1017 if (
present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1018 if (
present(xyave_axes)) axes%xyave_axes => xyave_axes
1021 axes%mask2d => null()
1022 if (axes%rank==2)
then
1023 if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1024 if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1025 if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1026 if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1029 axes%mask3d => null()
1030 if (axes%rank==3 .and. axes%is_native)
then
1032 if (axes%is_layer)
then
1033 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1034 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1035 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1036 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1037 elseif (axes%is_interface)
then
1038 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1039 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1040 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1041 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1045 end subroutine define_axes_group
1048 subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, &
1049 x_cell_method, y_cell_method, v_cell_method, &
1050 is_h_point, is_q_point, is_u_point, is_v_point, &
1051 is_layer, is_interface, &
1052 is_native, needs_remapping, needs_interpolating, &
1055 integer,
dimension(:),
intent(in) :: handles
1056 type(
axes_grp),
intent(out) :: axes
1057 integer,
intent(in) :: dl
1058 integer,
optional,
intent(in) :: nz
1059 integer,
optional,
intent(in) :: vertical_coordinate_number
1060 character(len=*),
optional,
intent(in) :: x_cell_method
1062 character(len=*),
optional,
intent(in) :: y_cell_method
1064 character(len=*),
optional,
intent(in) :: v_cell_method
1066 logical,
optional,
intent(in) :: is_h_point
1068 logical,
optional,
intent(in) :: is_q_point
1070 logical,
optional,
intent(in) :: is_u_point
1072 logical,
optional,
intent(in) :: is_v_point
1074 logical,
optional,
intent(in) :: is_layer
1076 logical,
optional,
intent(in) :: is_interface
1078 logical,
optional,
intent(in) :: is_native
1080 logical,
optional,
intent(in) :: needs_remapping
1083 logical,
optional,
intent(in) :: needs_interpolating
1086 type(
axes_grp),
optional,
target :: xyave_axes
1092 if (n<1 .or. n>3)
call mom_error(fatal,
"define_axes_group: wrong size for list of handles!")
1093 allocate( axes%handles(n) )
1094 axes%id = i2s(handles, n)
1096 axes%handles(:) = handles(:)
1097 axes%diag_cs => diag_cs
1098 if (
present(x_cell_method))
then
1099 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1100 'Can not set x_cell_method for rank<2.')
1101 axes%x_cell_method = trim(x_cell_method)
1103 axes%x_cell_method =
''
1105 if (
present(y_cell_method))
then
1106 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1107 'Can not set y_cell_method for rank<2.')
1108 axes%y_cell_method = trim(y_cell_method)
1110 axes%y_cell_method =
''
1112 if (
present(v_cell_method))
then
1113 if (axes%rank/=1 .and. axes%rank/=3)
call mom_error(fatal,
'define_axes_group: ' // &
1114 'Can not set v_cell_method for rank<>1 or 3.')
1115 axes%v_cell_method = trim(v_cell_method)
1117 axes%v_cell_method =
''
1119 axes%downsample_level = dl
1120 if (
present(nz)) axes%nz = nz
1121 if (
present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1122 if (
present(is_h_point)) axes%is_h_point = is_h_point
1123 if (
present(is_q_point)) axes%is_q_point = is_q_point
1124 if (
present(is_u_point)) axes%is_u_point = is_u_point
1125 if (
present(is_v_point)) axes%is_v_point = is_v_point
1126 if (
present(is_layer)) axes%is_layer = is_layer
1127 if (
present(is_interface)) axes%is_interface = is_interface
1128 if (
present(is_native)) axes%is_native = is_native
1129 if (
present(needs_remapping)) axes%needs_remapping = needs_remapping
1130 if (
present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1131 if (
present(xyave_axes)) axes%xyave_axes => xyave_axes
1135 axes%mask2d => null()
1136 if (axes%rank==2)
then
1137 if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1138 if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1139 if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1140 if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1143 axes%mask3d => null()
1144 if (axes%rank==3 .and. axes%is_native)
then
1146 if (axes%is_layer)
then
1147 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1148 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1149 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1150 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1151 elseif (axes%is_interface)
then
1152 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1153 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1154 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1155 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1159 axes%dsamp(dl)%mask2d => null()
1160 if (axes%rank==2)
then
1161 if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT
1162 if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu
1163 if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv
1164 if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu
1167 axes%dsamp(dl)%mask3d => null()
1168 if (axes%rank==3 .and. axes%is_native)
then
1170 if (axes%is_layer)
then
1171 if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL
1172 if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL
1173 if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL
1174 if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL
1175 elseif (axes%is_interface)
then
1176 if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi
1177 if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui
1178 if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi
1179 if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi
1183 end subroutine define_axes_group_dsamp
1186 subroutine set_diag_mediator_grid(G, diag_cs)
1188 type(
diag_ctrl),
intent(inout) :: diag_cs
1190 diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
1191 diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
1192 diag_cs%isd = g%isd ; diag_cs%ied = g%ied
1193 diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
1195 end subroutine set_diag_mediator_grid
1198 subroutine post_data_0d(diag_field_id, field, diag_cs, is_static)
1199 integer,
intent(in) :: diag_field_id
1201 real,
intent(in) :: field
1202 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1203 logical,
optional,
intent(in) :: is_static
1206 logical :: used, is_stat
1207 type(
diag_type),
pointer :: diag => null()
1209 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1210 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1214 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1215 'post_data_0d: Unregistered diagnostic id')
1216 diag => diag_cs%diags(diag_field_id)
1217 do while (
associated(diag))
1218 if (diag_cs%diag_as_chksum)
then
1219 call chksum0(field, diag%debug_str, logunit=diag_cs%chksum_iounit)
1220 else if (is_stat)
then
1221 used = send_data(diag%fms_diag_id, field)
1222 elseif (diag_cs%ave_enabled)
then
1223 used = send_data(diag%fms_diag_id, field, diag_cs%time_end)
1228 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1229 end subroutine post_data_0d
1232 subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static)
1233 integer,
intent(in) :: diag_field_id
1235 real,
target,
intent(in) :: field(:)
1236 type(
diag_ctrl),
target,
intent(in) :: diag_cs
1237 logical,
optional,
intent(in) :: is_static
1241 real,
dimension(:),
pointer :: locfield => null()
1243 integer :: k, ks, ke
1244 type(
diag_type),
pointer :: diag => null()
1246 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1247 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1250 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1251 'post_data_1d_k: Unregistered diagnostic id')
1252 diag => diag_cs%diags(diag_field_id)
1253 do while (
associated(diag))
1255 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1256 ks = lbound(field,1) ; ke = ubound(field,1)
1257 allocate( locfield( ks:ke ) )
1260 if (field(k) == diag_cs%missing_value)
then
1261 locfield(k) = diag_cs%missing_value
1263 locfield(k) = field(k) * diag%conversion_factor
1270 if (diag_cs%diag_as_chksum)
then
1271 call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit)
1272 else if (is_stat)
then
1273 used = send_data(diag%fms_diag_id, locfield)
1274 elseif (diag_cs%ave_enabled)
then
1275 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int)
1277 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1282 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1283 end subroutine post_data_1d_k
1286 subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask)
1287 integer,
intent(in) :: diag_field_id
1289 real,
intent(in) :: field(:,:)
1290 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1291 logical,
optional,
intent(in) :: is_static
1292 real,
optional,
intent(in) :: mask(:,:)
1295 type(
diag_type),
pointer :: diag => null()
1297 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1300 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1301 'post_data_2d: Unregistered diagnostic id')
1302 diag => diag_cs%diags(diag_field_id)
1303 do while (
associated(diag))
1304 call post_data_2d_low(diag, field, diag_cs, is_static, mask)
1308 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1309 end subroutine post_data_2d
1313 subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
1315 real,
target,
intent(in) :: field(:,:)
1317 logical,
optional,
intent(in) :: is_static
1318 real,
optional,
target,
intent(in) :: mask(:,:)
1321 real,
dimension(:,:),
pointer :: locfield
1322 real,
dimension(:,:),
pointer :: locmask
1323 character(len=300) :: mesg
1324 logical :: used, is_stat
1325 integer :: cszi, cszj, dszi, dszj
1326 integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o
1327 real,
dimension(:,:),
allocatable,
target :: locfield_dsamp
1328 real,
dimension(:,:),
allocatable,
target :: locmask_dsamp
1333 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1340 isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1342 cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1
1343 cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1
1344 if (
size(field,1) == dszi )
then
1345 isv = diag_cs%is ; iev = diag_cs%ie
1346 elseif (
size(field,1) == dszi + 1 )
then
1347 isv = diag_cs%is ; iev = diag_cs%ie+1
1348 elseif (
size(field,1) == cszi)
then
1349 isv = 1 ; iev = cszi
1350 elseif (
size(field,1) == cszi + 1 )
then
1351 isv = 1 ; iev = cszi+1
1353 write (mesg,*)
" peculiar size ",
size(field,1),
" in i-direction\n"//&
1354 "does not match one of ", cszi, cszi+1, dszi, dszi+1
1355 call mom_error(fatal,
"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1358 if (
size(field,2) == dszj )
then
1359 jsv = diag_cs%js ; jev = diag_cs%je
1360 elseif (
size(field,2) == dszj + 1 )
then
1361 jsv = diag_cs%js ; jev = diag_cs%je+1
1362 elseif (
size(field,2) == cszj )
then
1363 jsv = 1 ; jev = cszj
1364 elseif (
size(field,2) == cszj+1 )
then
1365 jsv = 1 ; jev = cszj+1
1367 write (mesg,*)
" peculiar size ",
size(field,2),
" in j-direction\n"//&
1368 "does not match one of ", cszj, cszj+1, dszj, dszj+1
1369 call mom_error(fatal,
"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1372 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1373 allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) )
1374 do j=jsv,jev ;
do i=isv,iev
1375 if (field(i,j) == diag_cs%missing_value)
then
1376 locfield(i,j) = diag_cs%missing_value
1378 locfield(i,j) = field(i,j) * diag%conversion_factor
1381 locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor
1386 if (
present(mask))
then
1388 elseif(.NOT. is_stat)
then
1389 if(
associated(diag%axes%mask2d)) locmask => diag%axes%mask2d
1393 if(.NOT. is_stat) dl = diag%axes%downsample_level
1396 isv_o=isv ; jsv_o=jsv
1398 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1399 locfield => locfield_dsamp
1400 if (
present(mask))
then
1401 call downsample_field_2d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1402 locmask => locmask_dsamp
1403 elseif(
associated(diag%axes%dsamp(dl)%mask2d))
then
1404 locmask => diag%axes%dsamp(dl)%mask2d
1408 if (diag_cs%diag_as_chksum)
then
1409 if (diag%axes%is_h_point)
then
1410 call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1411 logunit=diag_cs%chksum_iounit)
1412 else if (diag%axes%is_u_point)
then
1413 call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1414 logunit=diag_cs%chksum_iounit)
1415 else if (diag%axes%is_v_point)
then
1416 call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1417 logunit=diag_cs%chksum_iounit)
1418 else if (diag%axes%is_q_point)
then
1419 call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1420 logunit=diag_cs%chksum_iounit)
1422 call mom_error(fatal,
"post_data_2d_low: unknown axis type.")
1426 if (
present(mask))
then
1427 call assert(
size(locfield) ==
size(locmask), &
1428 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str)
1429 used = send_data(diag%fms_diag_id, locfield, &
1430 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1435 used = send_data(diag%fms_diag_id, locfield, &
1436 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1438 elseif (diag_cs%ave_enabled)
then
1439 if (
associated(locmask))
then
1440 call assert(
size(locfield) ==
size(locmask), &
1441 'post_data_2d_low: mask size mismatch: '//diag%debug_str)
1442 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1443 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1444 weight=diag_cs%time_int, rmask=locmask)
1446 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1447 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1448 weight=diag_cs%time_int)
1452 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1453 deallocate( locfield )
1454 end subroutine post_data_2d_low
1457 subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
1459 integer,
intent(in) :: diag_field_id
1461 real,
intent(in) :: field(:,:,:)
1462 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1463 logical,
optional,
intent(in) :: is_static
1464 real,
optional,
intent(in) :: mask(:,:,:)
1465 real,
dimension(:,:,:), &
1466 target,
optional,
intent(in) :: alt_h
1470 type(
diag_type),
pointer :: diag => null()
1471 integer :: nz, i, j, k
1472 real,
dimension(:,:,:),
allocatable :: remapped_field
1473 logical :: staggered_in_x, staggered_in_y
1474 real,
dimension(:,:,:),
pointer :: h_diag => null()
1476 if (
present(alt_h))
then
1482 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1486 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1487 'post_data_3d: Unregistered diagnostic id')
1488 diag => diag_cs%diags(diag_field_id)
1489 do while (
associated(diag))
1490 call assert(
associated(diag%axes),
'post_data_3d: axes is not associated')
1492 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1493 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1495 if (diag%v_extensive .and. .not.diag%axes%is_native)
then
1497 if (
present(mask))
then
1498 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1501 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1502 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz))
1503 call vertically_reintegrate_diag_field( &
1504 diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), &
1505 diag_cs%G, h_diag, staggered_in_x, staggered_in_y, &
1506 diag%axes%mask3d, diag_cs%missing_value, field, remapped_field)
1507 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1508 if (
associated(diag%axes%mask3d))
then
1511 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1512 mask=diag%axes%mask3d)
1514 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1516 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1517 deallocate(remapped_field)
1518 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1519 elseif (diag%axes%needs_remapping)
then
1521 if (
present(mask))
then
1522 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1525 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1526 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz))
1527 call diag_remap_do_remap(diag_cs%diag_remap_cs( &
1528 diag%axes%vertical_coordinate_number), &
1529 diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, &
1530 diag%axes%mask3d, diag_cs%missing_value, field, remapped_field)
1531 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1532 if (
associated(diag%axes%mask3d))
then
1535 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1536 mask=diag%axes%mask3d)
1538 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1540 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1541 deallocate(remapped_field)
1542 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1543 elseif (diag%axes%needs_interpolating)
then
1545 if (
present(mask))
then
1546 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1549 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1550 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz+1))
1551 call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( &
1552 diag%axes%vertical_coordinate_number), &
1553 diag_cs%G, h_diag, staggered_in_x, staggered_in_y, &
1554 diag%axes%mask3d, diag_cs%missing_value, field, remapped_field)
1555 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1556 if (
associated(diag%axes%mask3d))
then
1559 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1560 mask=diag%axes%mask3d)
1562 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1564 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1565 deallocate(remapped_field)
1566 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1568 call post_data_3d_low(diag, field, diag_cs, is_static, mask)
1572 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1574 end subroutine post_data_3d
1578 subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
1580 real,
target,
intent(in) :: field(:,:,:)
1582 logical,
optional,
intent(in) :: is_static
1583 real,
optional,
target,
intent(in) :: mask(:,:,:)
1586 real,
dimension(:,:,:),
pointer :: locfield
1587 real,
dimension(:,:,:),
pointer :: locmask
1588 character(len=300) :: mesg
1590 logical :: staggered_in_x, staggered_in_y
1592 integer :: cszi, cszj, dszi, dszj
1593 integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o
1595 real,
dimension(:,:,:),
allocatable,
target :: locfield_dsamp
1596 real,
dimension(:,:,:),
allocatable,
target :: locmask_dsamp
1601 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1608 isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1610 cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1
1611 cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1
1612 if (
size(field,1) == dszi )
then
1613 isv = diag_cs%is ; iev = diag_cs%ie
1614 elseif (
size(field,1) == dszi + 1 )
then
1615 isv = diag_cs%is ; iev = diag_cs%ie+1
1616 elseif (
size(field,1) == cszi)
then
1617 isv = 1 ; iev = cszi
1618 elseif (
size(field,1) == cszi + 1 )
then
1619 isv = 1 ; iev = cszi+1
1621 write (mesg,*)
" peculiar size ",
size(field,1),
" in i-direction\n"//&
1622 "does not match one of ", cszi, cszi+1, dszi, dszi+1
1623 call mom_error(fatal,
"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1626 if (
size(field,2) == dszj )
then
1627 jsv = diag_cs%js ; jev = diag_cs%je
1628 elseif (
size(field,2) == dszj + 1 )
then
1629 jsv = diag_cs%js ; jev = diag_cs%je+1
1630 elseif (
size(field,2) == cszj )
then
1631 jsv = 1 ; jev = cszj
1632 elseif (
size(field,2) == cszj+1 )
then
1633 jsv = 1 ; jev = cszj+1
1635 write (mesg,*)
" peculiar size ",
size(field,2),
" in j-direction\n"//&
1636 "does not match one of ", cszj, cszj+1, dszj, dszj+1
1637 call mom_error(fatal,
"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1640 ks = lbound(field,3) ; ke = ubound(field,3)
1641 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1642 allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) )
1645 isv_c = isv ; jsv_c = jsv
1646 if (diag%fms_xyave_diag_id>0)
then
1647 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1648 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1650 if (staggered_in_x) isv_c = iev - (diag_cs%ie - diag_cs%is) - 1
1651 if (staggered_in_y) jsv_c = jev - (diag_cs%je - diag_cs%js) - 1
1652 if (isv_c < lbound(locfield,1))
call mom_error(fatal, &
1653 "It is an error to average a staggered diagnostic field that does not "//&
1654 "have i-direction space to represent the symmetric computational domain.")
1655 if (jsv_c < lbound(locfield,2))
call mom_error(fatal, &
1656 "It is an error to average a staggered diagnostic field that does not "//&
1657 "have j-direction space to represent the symmetric computational domain.")
1660 do k=ks,ke ;
do j=jsv,jev ;
do i=isv,iev
1661 if (field(i,j,k) == diag_cs%missing_value)
then
1662 locfield(i,j,k) = diag_cs%missing_value
1664 locfield(i,j,k) = field(i,j,k) * diag%conversion_factor
1666 enddo ;
enddo ;
enddo
1671 if (
present(mask))
then
1673 elseif(
associated(diag%axes%mask3d))
then
1674 locmask => diag%axes%mask3d
1678 if(.NOT. is_stat) dl = diag%axes%downsample_level
1681 isv_o=isv ; jsv_o=jsv
1683 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1684 locfield => locfield_dsamp
1685 if (
present(mask))
then
1686 call downsample_field_3d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1687 locmask => locmask_dsamp
1688 elseif(
associated(diag%axes%dsamp(dl)%mask3d))
then
1689 locmask => diag%axes%dsamp(dl)%mask3d
1693 if (diag%fms_diag_id>0)
then
1694 if (diag_cs%diag_as_chksum)
then
1695 if (diag%axes%is_h_point)
then
1696 call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1697 logunit=diag_cs%chksum_iounit)
1698 else if (diag%axes%is_u_point)
then
1699 call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1700 logunit=diag_cs%chksum_iounit)
1701 else if (diag%axes%is_v_point)
then
1702 call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1703 logunit=diag_cs%chksum_iounit)
1704 else if (diag%axes%is_q_point)
then
1705 call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1706 logunit=diag_cs%chksum_iounit)
1708 call mom_error(fatal,
"post_data_3d_low: unknown axis type.")
1712 if (
present(mask))
then
1713 call assert(
size(locfield) ==
size(locmask), &
1714 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str)
1715 used = send_data(diag%fms_diag_id, locfield, &
1716 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1721 used = send_data(diag%fms_diag_id, locfield, &
1722 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1724 elseif (diag_cs%ave_enabled)
then
1725 if (
associated(locmask))
then
1726 call assert(
size(locfield) ==
size(locmask), &
1727 'post_data_3d_low: mask size mismatch: '//diag%debug_str)
1728 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1729 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1730 weight=diag_cs%time_int, rmask=locmask)
1732 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1733 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1734 weight=diag_cs%time_int)
1740 if (diag%fms_xyave_diag_id>0)
then
1741 call post_xy_average(diag_cs, diag, locfield)
1744 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1745 deallocate( locfield )
1747 end subroutine post_data_3d_low
1750 subroutine post_xy_average(diag_cs, diag, field)
1752 real,
target,
intent(in) :: field(:,:,:)
1755 real,
dimension(size(field,3)) :: averaged_field
1756 logical,
dimension(size(field,3)) :: averaged_mask
1757 logical :: staggered_in_x, staggered_in_y, used
1758 integer :: nz, remap_nz, coord
1760 if (.not. diag_cs%ave_enabled)
then
1764 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1765 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1767 if (diag%axes%is_native)
then
1768 call horizontally_average_diag_field(diag_cs%G, diag_cs%h, &
1769 staggered_in_x, staggered_in_y, &
1770 diag%axes%is_layer, diag%v_extensive, &
1771 diag_cs%missing_value, field, &
1772 averaged_field, averaged_mask)
1775 coord = diag%axes%vertical_coordinate_number
1776 remap_nz = diag_cs%diag_remap_cs(coord)%nz
1778 call assert(diag_cs%diag_remap_cs(coord)%initialized, &
1779 'post_xy_average: remap_cs not initialized.')
1781 call assert(implies(diag%axes%is_layer, nz == remap_nz), &
1782 'post_xy_average: layer field dimension mismatch.')
1783 call assert(implies(.not. diag%axes%is_layer, nz == remap_nz+1), &
1784 'post_xy_average: interface field dimension mismatch.')
1786 call horizontally_average_diag_field(diag_cs%G, diag_cs%diag_remap_cs(coord)%h, &
1787 staggered_in_x, staggered_in_y, &
1788 diag%axes%is_layer, diag%v_extensive, &
1789 diag_cs%missing_value, field, &
1790 averaged_field, averaged_mask)
1793 if (diag_cs%diag_as_chksum)
then
1794 call zchksum(averaged_field, trim(diag%debug_str)//
'_xyave', &
1795 logunit=diag_cs%chksum_iounit)
1797 used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, &
1798 weight=diag_cs%time_int, mask=averaged_mask)
1800 end subroutine post_xy_average
1803 subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
1804 real,
intent(in) :: time_int_in
1806 type(time_type),
intent(in) :: time_end_in
1807 type(
diag_ctrl),
intent(inout) :: diag_cs
1813 diag_cs%time_int = time_int_in
1814 diag_cs%time_end = time_end_in
1815 diag_cs%ave_enabled = .true.
1816 end subroutine enable_averaging
1819 subroutine disable_averaging(diag_cs)
1822 diag_cs%time_int = 0.0
1823 diag_cs%ave_enabled = .false.
1825 end subroutine disable_averaging
1829 function query_averaging_enabled(diag_cs, time_int, time_end)
1831 real,
optional,
intent(out) :: time_int
1832 type(time_type),
optional,
intent(out) :: time_end
1833 logical :: query_averaging_enabled
1835 if (
present(time_int)) time_int = diag_cs%time_int
1836 if (
present(time_end)) time_end = diag_cs%time_end
1837 query_averaging_enabled = diag_cs%ave_enabled
1838 end function query_averaging_enabled
1842 function get_diag_time_end(diag_cs)
1844 type(time_type) :: get_diag_time_end
1848 get_diag_time_end = diag_cs%time_end
1849 end function get_diag_time_end
1853 integer function register_diag_field(module_name, field_name, axes_in, init_time, &
1854 long_name, units, missing_value, range, mask_variant, standard_name, &
1855 verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
1856 cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
1857 x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
1858 character(len=*),
intent(in) :: module_name
1860 character(len=*),
intent(in) :: field_name
1861 type(
axes_grp),
target,
intent(in) :: axes_in
1863 type(time_type),
intent(in) :: init_time
1864 character(len=*),
optional,
intent(in) :: long_name
1865 character(len=*),
optional,
intent(in) :: units
1866 character(len=*),
optional,
intent(in) :: standard_name
1867 real,
optional,
intent(in) :: missing_value
1868 real,
optional,
intent(in) :: range(2)
1869 logical,
optional,
intent(in) :: mask_variant
1871 logical,
optional,
intent(in) :: verbose
1872 logical,
optional,
intent(in) :: do_not_log
1873 character(len=*),
optional,
intent(out):: err_msg
1875 character(len=*),
optional,
intent(in) :: interp_method
1877 integer,
optional,
intent(in) :: tile_count
1878 character(len=*),
optional,
intent(in) :: cmor_field_name
1879 character(len=*),
optional,
intent(in) :: cmor_long_name
1880 character(len=*),
optional,
intent(in) :: cmor_units
1881 character(len=*),
optional,
intent(in) :: cmor_standard_name
1882 character(len=*),
optional,
intent(in) :: cell_methods
1886 character(len=*),
optional,
intent(in) :: x_cell_method
1888 character(len=*),
optional,
intent(in) :: y_cell_method
1890 character(len=*),
optional,
intent(in) :: v_cell_method
1892 real,
optional,
intent(in) :: conversion
1893 logical,
optional,
intent(in) :: v_extensive
1896 real :: mom_missing_value
1897 type(
diag_ctrl),
pointer :: diag_cs => null()
1898 type(
axes_grp),
pointer :: remap_axes => null()
1899 type(
axes_grp),
pointer :: axes => null()
1900 integer :: dm_id, i, dl
1901 character(len=256) :: new_module_name
1905 mom_missing_value = axes%diag_cs%missing_value
1906 if (
present(missing_value)) mom_missing_value = missing_value
1908 diag_cs => axes%diag_cs
1911 if (axes_in%id == diag_cs%axesTL%id)
then
1912 axes => diag_cs%axesTL
1913 elseif (axes_in%id == diag_cs%axesBL%id)
then
1914 axes => diag_cs%axesBL
1915 elseif (axes_in%id == diag_cs%axesCuL%id )
then
1916 axes => diag_cs%axesCuL
1917 elseif (axes_in%id == diag_cs%axesCvL%id)
then
1918 axes => diag_cs%axesCvL
1919 elseif (axes_in%id == diag_cs%axesTi%id)
then
1920 axes => diag_cs%axesTi
1921 elseif (axes_in%id == diag_cs%axesBi%id)
then
1922 axes => diag_cs%axesBi
1923 elseif (axes_in%id == diag_cs%axesCui%id )
then
1924 axes => diag_cs%axesCui
1925 elseif (axes_in%id == diag_cs%axesCvi%id)
then
1926 axes => diag_cs%axesCvi
1930 active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, &
1931 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
1932 range=range, mask_variant=mask_variant, standard_name=standard_name, &
1933 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
1934 interp_method=interp_method, tile_count=tile_count, &
1935 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
1936 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
1937 cell_methods=cell_methods, x_cell_method=x_cell_method, &
1938 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
1939 conversion=conversion, v_extensive=v_extensive)
1942 do i=1,diag_cs%num_diag_coords
1943 new_module_name = trim(module_name)//
'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)
1946 if (axes_in%rank == 3)
then
1947 remap_axes => null()
1948 if ((axes_in%id == diag_cs%axesTL%id))
then
1949 remap_axes => diag_cs%remap_axesTL(i)
1950 elseif (axes_in%id == diag_cs%axesBL%id)
then
1951 remap_axes => diag_cs%remap_axesBL(i)
1952 elseif (axes_in%id == diag_cs%axesCuL%id )
then
1953 remap_axes => diag_cs%remap_axesCuL(i)
1954 elseif (axes_in%id == diag_cs%axesCvL%id)
then
1955 remap_axes => diag_cs%remap_axesCvL(i)
1956 elseif (axes_in%id == diag_cs%axesTi%id)
then
1957 remap_axes => diag_cs%remap_axesTi(i)
1958 elseif (axes_in%id == diag_cs%axesBi%id)
then
1959 remap_axes => diag_cs%remap_axesBi(i)
1960 elseif (axes_in%id == diag_cs%axesCui%id )
then
1961 remap_axes => diag_cs%remap_axesCui(i)
1962 elseif (axes_in%id == diag_cs%axesCvi%id)
then
1963 remap_axes => diag_cs%remap_axesCvi(i)
1968 if (
associated(remap_axes))
then
1969 if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating)
then
1970 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
1971 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
1972 range=range, mask_variant=mask_variant, standard_name=standard_name, &
1973 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
1974 interp_method=interp_method, tile_count=tile_count, &
1975 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
1976 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
1977 cell_methods=cell_methods, x_cell_method=x_cell_method, &
1978 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
1979 conversion=conversion, v_extensive=v_extensive)
1981 call diag_remap_set_active(diag_cs%diag_remap_cs(i))
1989 do dl=2,max_dsamp_lev
1991 if (diag_cs%diag_as_chksum) cycle
1993 new_module_name = trim(module_name)//
'_d2'
1995 if (axes_in%rank == 3 .or. axes_in%rank == 2 )
then
1997 if (axes_in%id == diag_cs%axesTL%id)
then
1998 axes => diag_cs%dsamp(dl)%axesTL
1999 elseif (axes_in%id == diag_cs%axesBL%id)
then
2000 axes => diag_cs%dsamp(dl)%axesBL
2001 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2002 axes => diag_cs%dsamp(dl)%axesCuL
2003 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2004 axes => diag_cs%dsamp(dl)%axesCvL
2005 elseif (axes_in%id == diag_cs%axesTi%id)
then
2006 axes => diag_cs%dsamp(dl)%axesTi
2007 elseif (axes_in%id == diag_cs%axesBi%id)
then
2008 axes => diag_cs%dsamp(dl)%axesBi
2009 elseif (axes_in%id == diag_cs%axesCui%id )
then
2010 axes => diag_cs%dsamp(dl)%axesCui
2011 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2012 axes => diag_cs%dsamp(dl)%axesCvi
2013 elseif (axes_in%id == diag_cs%axesT1%id)
then
2014 axes => diag_cs%dsamp(dl)%axesT1
2015 elseif (axes_in%id == diag_cs%axesB1%id)
then
2016 axes => diag_cs%dsamp(dl)%axesB1
2017 elseif (axes_in%id == diag_cs%axesCu1%id )
then
2018 axes => diag_cs%dsamp(dl)%axesCu1
2019 elseif (axes_in%id == diag_cs%axesCv1%id)
then
2020 axes => diag_cs%dsamp(dl)%axesCv1
2023 call mom_error(warning,
"register_diag_field: Could not find a proper axes for " &
2024 //trim( new_module_name)//
"-"//trim(field_name))
2028 if (
associated(axes))
then
2029 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, &
2030 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2031 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2032 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2033 interp_method=interp_method, tile_count=tile_count, &
2034 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2035 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2036 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2037 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2038 conversion=conversion, v_extensive=v_extensive)
2042 do i=1,diag_cs%num_diag_coords
2043 new_module_name = trim(module_name)//
'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//
'_d2'
2046 if (axes_in%rank == 3)
then
2047 remap_axes => null()
2048 if ((axes_in%id == diag_cs%axesTL%id))
then
2049 remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i)
2050 elseif (axes_in%id == diag_cs%axesBL%id)
then
2051 remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i)
2052 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2053 remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i)
2054 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2055 remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i)
2056 elseif (axes_in%id == diag_cs%axesTi%id)
then
2057 remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i)
2058 elseif (axes_in%id == diag_cs%axesBi%id)
then
2059 remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i)
2060 elseif (axes_in%id == diag_cs%axesCui%id )
then
2061 remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i)
2062 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2063 remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i)
2069 if (
associated(remap_axes))
then
2070 if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating)
then
2071 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
2072 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2073 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2074 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2075 interp_method=interp_method, tile_count=tile_count, &
2076 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2077 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2078 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2079 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2080 conversion=conversion, v_extensive=v_extensive)
2082 call diag_remap_set_active(diag_cs%diag_remap_cs(i))
2090 register_diag_field = dm_id
2092 end function register_diag_field
2096 logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, &
2097 long_name, units, missing_value, range, mask_variant, standard_name, &
2098 verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
2099 cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
2100 x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
2101 integer,
intent(inout) :: dm_id
2102 character(len=*),
intent(in) :: module_name
2103 character(len=*),
intent(in) :: field_name
2104 type(
axes_grp),
target,
intent(in) :: axes
2106 type(time_type),
intent(in) :: init_time
2107 character(len=*),
optional,
intent(in) :: long_name
2108 character(len=*),
optional,
intent(in) :: units
2109 character(len=*),
optional,
intent(in) :: standard_name
2110 real,
optional,
intent(in) :: missing_value
2111 real,
optional,
intent(in) :: range(2)
2112 logical,
optional,
intent(in) :: mask_variant
2114 logical,
optional,
intent(in) :: verbose
2115 logical,
optional,
intent(in) :: do_not_log
2116 character(len=*),
optional,
intent(out):: err_msg
2118 character(len=*),
optional,
intent(in) :: interp_method
2120 integer,
optional,
intent(in) :: tile_count
2121 character(len=*),
optional,
intent(in) :: cmor_field_name
2122 character(len=*),
optional,
intent(in) :: cmor_long_name
2123 character(len=*),
optional,
intent(in) :: cmor_units
2124 character(len=*),
optional,
intent(in) :: cmor_standard_name
2125 character(len=*),
optional,
intent(in) :: cell_methods
2129 character(len=*),
optional,
intent(in) :: x_cell_method
2131 character(len=*),
optional,
intent(in) :: y_cell_method
2133 character(len=*),
optional,
intent(in) :: v_cell_method
2135 real,
optional,
intent(in) :: conversion
2136 logical,
optional,
intent(in) :: v_extensive
2139 real :: mom_missing_value
2140 type(
diag_ctrl),
pointer :: diag_cs => null()
2141 type(
diag_type),
pointer :: this_diag => null()
2142 integer :: fms_id, fms_xyave_id
2143 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg
2145 mom_missing_value = axes%diag_cs%missing_value
2146 if (
present(missing_value)) mom_missing_value = missing_value
2148 register_diag_field_expand_cmor = .false.
2149 diag_cs => axes%diag_cs
2152 fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2153 long_name=long_name, units=units, missing_value=mom_missing_value, &
2154 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2155 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2156 interp_method=interp_method, tile_count=tile_count)
2157 if (.not. diag_cs%diag_as_chksum) &
2158 call attach_cell_methods(fms_id, axes, cm_string, cell_methods, &
2159 x_cell_method, y_cell_method, v_cell_method, &
2160 v_extensive=v_extensive)
2161 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2163 if (
present(cmor_field_name)) msg =
'CMOR equivalent is "'//trim(cmor_field_name)//
'"'
2164 call log_available_diag(fms_id>0, module_name, field_name, cm_string, &
2165 msg, diag_cs, long_name, units, standard_name)
2168 fms_xyave_id = diag_field_not_found
2169 if (
associated(axes%xyave_axes))
then
2170 fms_xyave_id = register_diag_field_expand_axes(module_name, trim(field_name)//
'_xyave', &
2171 axes%xyave_axes, init_time, &
2172 long_name=long_name, units=units, missing_value=mom_missing_value, &
2173 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2174 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2175 interp_method=interp_method, tile_count=tile_count)
2176 if (.not. diag_cs%diag_as_chksum) &
2177 call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2178 cell_methods, v_cell_method, v_extensive=v_extensive)
2179 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2181 if (
present(cmor_field_name)) msg =
'CMOR equivalent is "'//trim(cmor_field_name)//
'_xyave"'
2182 call log_available_diag(fms_xyave_id>0, module_name, trim(field_name)//
'_xyave', cm_string, &
2183 msg, diag_cs, long_name, units, standard_name)
2187 if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found)
then
2188 call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2189 this_diag%fms_xyave_diag_id = fms_xyave_id
2191 call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2192 if (
present(v_extensive)) this_diag%v_extensive = v_extensive
2193 if (
present(conversion)) this_diag%conversion_factor = conversion
2194 register_diag_field_expand_cmor = .true.
2198 if (
present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum)
then
2200 posted_cmor_units =
"not provided"
2201 posted_cmor_standard_name =
"not provided"
2202 posted_cmor_long_name =
"not provided"
2206 if (
present(units)) posted_cmor_units = units
2207 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2208 if (
present(long_name)) posted_cmor_long_name = long_name
2211 if (
present(cmor_units)) posted_cmor_units = cmor_units
2212 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2213 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2215 fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, &
2216 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2217 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2218 standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2219 err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2220 call attach_cell_methods(fms_id, axes, cm_string, &
2221 cell_methods, x_cell_method, y_cell_method, v_cell_method, &
2222 v_extensive=v_extensive)
2223 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2224 msg =
'native name is "'//trim(field_name)//
'"'
2225 call log_available_diag(fms_id>0, module_name, cmor_field_name, cm_string, &
2226 msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2227 posted_cmor_standard_name)
2230 fms_xyave_id = diag_field_not_found
2231 if (
associated(axes%xyave_axes))
then
2232 fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//
'_xyave', &
2233 axes%xyave_axes, init_time, &
2234 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2235 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2236 standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2237 err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2238 call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2239 cell_methods, v_cell_method, v_extensive=v_extensive)
2240 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2241 msg =
'native name is "'//trim(field_name)//
'_xyave"'
2242 call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//
'_xyave', &
2243 cm_string, msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2244 posted_cmor_standard_name)
2248 if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found)
then
2249 call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2250 this_diag%fms_xyave_diag_id = fms_xyave_id
2252 call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2253 if (
present(v_extensive)) this_diag%v_extensive = v_extensive
2254 if (
present(conversion)) this_diag%conversion_factor = conversion
2255 register_diag_field_expand_cmor = .true.
2259 end function register_diag_field_expand_cmor
2263 integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2264 long_name, units, missing_value, range, mask_variant, standard_name, &
2265 verbose, do_not_log, err_msg, interp_method, tile_count)
2266 character(len=*),
intent(in) :: module_name
2268 character(len=*),
intent(in) :: field_name
2269 type(
axes_grp),
target,
intent(in) :: axes
2271 type(time_type),
intent(in) :: init_time
2272 character(len=*),
optional,
intent(in) :: long_name
2273 character(len=*),
optional,
intent(in) :: units
2274 character(len=*),
optional,
intent(in) :: standard_name
2275 real,
optional,
intent(in) :: missing_value
2276 real,
optional,
intent(in) :: range(2)
2277 logical,
optional,
intent(in) :: mask_variant
2279 logical,
optional,
intent(in) :: verbose
2280 logical,
optional,
intent(in) :: do_not_log
2282 character(len=*),
optional,
intent(out):: err_msg
2284 character(len=*),
optional,
intent(in) :: interp_method
2286 integer,
optional,
intent(in) :: tile_count
2288 integer :: fms_id, area_id, volume_id
2291 area_id = axes%id_area
2292 volume_id = axes%id_volume
2295 if (axes%diag_cs%diag_as_chksum)
then
2296 fms_id = axes%diag_cs%num_chksum_diags + 1
2297 axes%diag_cs%num_chksum_diags = fms_id
2298 else if (
present(interp_method) .or. axes%is_h_point)
then
2301 if (volume_id>0)
then
2303 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2304 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2305 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2306 interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id)
2309 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2310 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2311 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2312 interp_method=interp_method, tile_count=tile_count, area=area_id)
2315 if (volume_id>0)
then
2317 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2318 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2319 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2320 interp_method=interp_method, tile_count=tile_count, volume=volume_id)
2323 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2324 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2325 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2326 interp_method=interp_method, tile_count=tile_count)
2332 if (volume_id>0)
then
2334 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2335 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2336 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2337 interp_method=
'none', tile_count=tile_count, area=area_id, volume=volume_id)
2340 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2341 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2342 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2343 interp_method=
'none', tile_count=tile_count, area=area_id)
2346 if (volume_id>0)
then
2348 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2349 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2350 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2351 interp_method=
'none', tile_count=tile_count, volume=volume_id)
2354 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2355 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2356 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2357 interp_method=
'none', tile_count=tile_count)
2362 register_diag_field_expand_axes = fms_id
2364 end function register_diag_field_expand_axes
2367 subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2369 integer,
intent(inout) :: dm_id
2370 integer,
intent(in) :: fms_id
2372 type(
axes_grp),
target,
intent(in) :: axes
2374 character(len=*),
intent(in) :: module_name
2376 character(len=*),
intent(in) :: field_name
2377 character(len=*),
intent(in) :: msg
2380 if (dm_id == -1) dm_id = get_new_diag_id(diag_cs)
2382 call alloc_diag_with_id(dm_id, diag_cs, this_diag)
2383 call assert(
associated(this_diag), trim(msg)//
': diag_type allocation failed')
2385 this_diag%fms_diag_id = fms_id
2386 this_diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2387 this_diag%axes => axes
2389 end subroutine add_diag_to_list
2393 subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2397 character(len=*),
optional,
intent(in) :: x_cell_method
2399 character(len=*),
optional,
intent(in) :: y_cell_method
2401 character(len=*),
optional,
intent(in) :: v_cell_method
2403 logical,
optional,
intent(in) :: v_extensive
2405 integer :: xyz_method
2406 character(len=9) :: mstr
2417 mstr = diag%axes%v_cell_method
2418 if (
present(v_extensive))
then
2419 if (
present(v_cell_method))
call mom_error(fatal,
"attach_cell_methods: " // &
2420 'Vertical cell method was specified along with the vertically extensive flag.')
2421 if(v_extensive)
then
2426 elseif (
present(v_cell_method))
then
2427 mstr = v_cell_method
2429 if (trim(mstr)==
'sum')
then
2430 xyz_method = xyz_method + 1
2431 elseif (trim(mstr)==
'mean')
then
2432 xyz_method = xyz_method + 2
2435 mstr = diag%axes%y_cell_method
2436 if (
present(y_cell_method)) mstr = y_cell_method
2437 if (trim(mstr)==
'sum')
then
2438 xyz_method = xyz_method + 10
2439 elseif (trim(mstr)==
'mean')
then
2440 xyz_method = xyz_method + 20
2443 mstr = diag%axes%x_cell_method
2444 if (
present(x_cell_method)) mstr = x_cell_method
2445 if (trim(mstr)==
'sum')
then
2446 xyz_method = xyz_method + 100
2447 elseif (trim(mstr)==
'mean')
then
2448 xyz_method = xyz_method + 200
2451 diag%xyz_method = xyz_method
2452 end subroutine add_xyz_method
2455 subroutine attach_cell_methods(id, axes, ostring, cell_methods, &
2456 x_cell_method, y_cell_method, v_cell_method, v_extensive)
2457 integer,
intent(in) :: id
2460 character(len=*),
intent(out) :: ostring
2461 character(len=*),
optional,
intent(in) :: cell_methods
2465 character(len=*),
optional,
intent(in) :: x_cell_method
2467 character(len=*),
optional,
intent(in) :: y_cell_method
2469 character(len=*),
optional,
intent(in) :: v_cell_method
2471 logical,
optional,
intent(in) :: v_extensive
2474 character(len=9) :: axis_name
2475 logical :: x_mean, y_mean, x_sum, y_sum
2483 if (
present(cell_methods))
then
2484 if (
present(x_cell_method) .or.
present(y_cell_method) .or.
present(v_cell_method) &
2485 .or.
present(v_extensive))
then
2486 call mom_error(fatal,
"attach_cell_methods: " // &
2487 'Individual direction cell method was specified along with a "cell_methods" string.')
2489 if (len(trim(cell_methods))>0)
then
2490 call diag_field_add_attribute(id,
'cell_methods', trim(cell_methods))
2491 ostring = trim(cell_methods)
2494 if (
present(x_cell_method))
then
2495 if (len(trim(x_cell_method))>0)
then
2496 call get_diag_axis_name(axes%handles(1), axis_name)
2497 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(x_cell_method))
2498 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(x_cell_method)
2499 if (trim(x_cell_method)==
'mean') x_mean=.true.
2500 if (trim(x_cell_method)==
'sum') x_sum=.true.
2503 if (len(trim(axes%x_cell_method))>0)
then
2504 call get_diag_axis_name(axes%handles(1), axis_name)
2505 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%x_cell_method))
2506 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%x_cell_method)
2507 if (trim(axes%x_cell_method)==
'mean') x_mean=.true.
2508 if (trim(axes%x_cell_method)==
'sum') x_sum=.true.
2511 if (
present(y_cell_method))
then
2512 if (len(trim(y_cell_method))>0)
then
2513 call get_diag_axis_name(axes%handles(2), axis_name)
2514 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(y_cell_method))
2515 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(y_cell_method)
2516 if (trim(y_cell_method)==
'mean') y_mean=.true.
2517 if (trim(y_cell_method)==
'sum') y_sum=.true.
2520 if (len(trim(axes%y_cell_method))>0)
then
2521 call get_diag_axis_name(axes%handles(2), axis_name)
2522 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%y_cell_method))
2523 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%y_cell_method)
2524 if (trim(axes%y_cell_method)==
'mean') y_mean=.true.
2525 if (trim(axes%y_cell_method)==
'sum') y_sum=.true.
2528 if (
present(v_cell_method))
then
2529 if (
present(v_extensive))
call mom_error(fatal,
"attach_cell_methods: " // &
2530 'Vertical cell method was specified along with the vertically extensive flag.')
2531 if (len(trim(v_cell_method))>0)
then
2532 if (axes%rank==1)
then
2533 call get_diag_axis_name(axes%handles(1), axis_name)
2534 elseif (axes%rank==3)
then
2535 call get_diag_axis_name(axes%handles(3), axis_name)
2537 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(v_cell_method))
2538 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(v_cell_method)
2540 elseif (
present(v_extensive))
then
2541 if(v_extensive)
then
2542 if (axes%rank==1)
then
2543 call get_diag_axis_name(axes%handles(1), axis_name)
2544 elseif (axes%rank==3)
then
2545 call get_diag_axis_name(axes%handles(3), axis_name)
2547 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':sum')
2548 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':sum'
2551 if (len(trim(axes%v_cell_method))>0)
then
2552 if (axes%rank==1)
then
2553 call get_diag_axis_name(axes%handles(1), axis_name)
2554 elseif (axes%rank==3)
then
2555 call get_diag_axis_name(axes%handles(3), axis_name)
2557 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%v_cell_method))
2558 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%v_cell_method)
2561 if (x_mean .and. y_mean)
then
2562 call diag_field_add_attribute(id,
'cell_methods',
'area:mean')
2563 ostring = trim(adjustl(ostring))//
' area:mean'
2564 elseif (x_sum .and. y_sum)
then
2565 call diag_field_add_attribute(id,
'cell_methods',
'area:sum')
2566 ostring = trim(adjustl(ostring))//
' area:sum'
2569 ostring = adjustl(ostring)
2570 end subroutine attach_cell_methods
2572 function register_scalar_field(module_name, field_name, init_time, diag_cs, &
2573 long_name, units, missing_value, range, standard_name, &
2574 do_not_log, err_msg, interp_method, cmor_field_name, &
2575 cmor_long_name, cmor_units, cmor_standard_name)
2576 integer :: register_scalar_field
2577 character(len=*),
intent(in) :: module_name
2579 character(len=*),
intent(in) :: field_name
2580 type(time_type),
intent(in) :: init_time
2581 type(
diag_ctrl),
intent(inout) :: diag_cs
2582 character(len=*),
optional,
intent(in) :: long_name
2583 character(len=*),
optional,
intent(in) :: units
2584 character(len=*),
optional,
intent(in) :: standard_name
2585 real,
optional,
intent(in) :: missing_value
2586 real,
optional,
intent(in) :: range(2)
2587 logical,
optional,
intent(in) :: do_not_log
2588 character(len=*),
optional,
intent(out):: err_msg
2590 character(len=*),
optional,
intent(in) :: interp_method
2592 character(len=*),
optional,
intent(in) :: cmor_field_name
2593 character(len=*),
optional,
intent(in) :: cmor_long_name
2594 character(len=*),
optional,
intent(in) :: cmor_units
2595 character(len=*),
optional,
intent(in) :: cmor_standard_name
2598 real :: mom_missing_value
2599 integer :: dm_id, fms_id
2600 type(
diag_type),
pointer :: diag => null(), cmor_diag => null()
2601 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2603 mom_missing_value = diag_cs%missing_value
2604 if (
present(missing_value)) mom_missing_value = missing_value
2610 if (diag_cs%diag_as_chksum)
then
2611 fms_id = diag_cs%num_chksum_diags + 1
2612 diag_cs%num_chksum_diags = fms_id
2615 long_name=long_name, units=units, missing_value=mom_missing_value, &
2616 range=range, standard_name=standard_name, do_not_log=do_not_log, &
2620 if (fms_id /= diag_field_not_found)
then
2621 dm_id = get_new_diag_id(diag_cs)
2622 call alloc_diag_with_id(dm_id, diag_cs, diag)
2623 call assert(
associated(diag),
'register_scalar_field: diag allocation failed')
2624 diag%fms_diag_id = fms_id
2625 diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2628 if (
present(cmor_field_name))
then
2630 posted_cmor_units =
"not provided"
2631 posted_cmor_standard_name =
"not provided"
2632 posted_cmor_long_name =
"not provided"
2636 if (
present(units)) posted_cmor_units = units
2637 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2638 if (
present(long_name)) posted_cmor_long_name = long_name
2641 if (
present(cmor_units)) posted_cmor_units = cmor_units
2642 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2643 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2646 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2647 missing_value=mom_missing_value, range=range, &
2648 standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg)
2649 if (fms_id /= diag_field_not_found)
then
2650 if (dm_id == -1)
then
2651 dm_id = get_new_diag_id(diag_cs)
2653 call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2654 cmor_diag%fms_diag_id = fms_id
2655 cmor_diag%debug_str = trim(module_name)//
"-"//trim(cmor_field_name)
2660 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2661 call log_available_diag(
associated(diag), module_name, field_name,
'',
'', diag_cs, &
2662 long_name, units, standard_name)
2663 if (
present(cmor_field_name))
then
2664 call log_available_diag(
associated(cmor_diag), module_name, cmor_field_name, &
2665 '',
'', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2666 posted_cmor_standard_name)
2670 register_scalar_field = dm_id
2672 end function register_scalar_field
2675 function register_static_field(module_name, field_name, axes, &
2676 long_name, units, missing_value, range, mask_variant, standard_name, &
2677 do_not_log, interp_method, tile_count, &
2678 cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, &
2679 x_cell_method, y_cell_method, area_cell_method, conversion)
2680 integer :: register_static_field
2681 character(len=*),
intent(in) :: module_name
2683 character(len=*),
intent(in) :: field_name
2684 type(
axes_grp),
target,
intent(in) :: axes
2686 character(len=*),
optional,
intent(in) :: long_name
2687 character(len=*),
optional,
intent(in) :: units
2688 character(len=*),
optional,
intent(in) :: standard_name
2689 real,
optional,
intent(in) :: missing_value
2690 real,
optional,
intent(in) :: range(2)
2691 logical,
optional,
intent(in) :: mask_variant
2693 logical,
optional,
intent(in) :: do_not_log
2694 character(len=*),
optional,
intent(in) :: interp_method
2696 integer,
optional,
intent(in) :: tile_count
2697 character(len=*),
optional,
intent(in) :: cmor_field_name
2698 character(len=*),
optional,
intent(in) :: cmor_long_name
2699 character(len=*),
optional,
intent(in) :: cmor_units
2700 character(len=*),
optional,
intent(in) :: cmor_standard_name
2701 integer,
optional,
intent(in) :: area
2702 character(len=*),
optional,
intent(in) :: x_cell_method
2703 character(len=*),
optional,
intent(in) :: y_cell_method
2704 character(len=*),
optional,
intent(in) :: area_cell_method
2705 real,
optional,
intent(in) :: conversion
2708 real :: mom_missing_value
2709 type(
diag_ctrl),
pointer :: diag_cs => null()
2710 type(
diag_type),
pointer :: diag => null(), cmor_diag => null()
2711 integer :: dm_id, fms_id, cmor_id
2712 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2713 character(len=9) :: axis_name
2715 mom_missing_value = axes%diag_cs%missing_value
2716 if (
present(missing_value)) mom_missing_value = missing_value
2718 diag_cs => axes%diag_cs
2723 if (diag_cs%diag_as_chksum)
then
2724 fms_id = diag_cs%num_chksum_diags + 1
2725 diag_cs%num_chksum_diags = fms_id
2727 fms_id = register_static_field_fms(module_name, field_name, axes%handles, &
2728 long_name=long_name, units=units, missing_value=mom_missing_value, &
2729 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2730 do_not_log=do_not_log, &
2731 interp_method=interp_method, tile_count=tile_count, area=area)
2734 if (fms_id /= diag_field_not_found)
then
2735 dm_id = get_new_diag_id(diag_cs)
2736 call alloc_diag_with_id(dm_id, diag_cs, diag)
2737 call assert(
associated(diag),
'register_static_field: diag allocation failed')
2738 diag%fms_diag_id = fms_id
2739 diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2740 if (
present(conversion)) diag%conversion_factor = conversion
2742 if (diag_cs%diag_as_chksum)
then
2745 if (
present(x_cell_method))
then
2746 call get_diag_axis_name(axes%handles(1), axis_name)
2747 call diag_field_add_attribute(fms_id,
'cell_methods', &
2748 trim(axis_name)//
':'//trim(x_cell_method))
2750 if (
present(y_cell_method))
then
2751 call get_diag_axis_name(axes%handles(2), axis_name)
2752 call diag_field_add_attribute(fms_id,
'cell_methods', &
2753 trim(axis_name)//
':'//trim(y_cell_method))
2755 if (
present(area_cell_method))
then
2756 call diag_field_add_attribute(fms_id,
'cell_methods', &
2757 'area:'//trim(area_cell_method))
2762 if (
present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum)
then
2764 posted_cmor_units =
"not provided"
2765 posted_cmor_standard_name =
"not provided"
2766 posted_cmor_long_name =
"not provided"
2770 if (
present(units)) posted_cmor_units = units
2771 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2772 if (
present(long_name)) posted_cmor_long_name = long_name
2775 if (
present(cmor_units)) posted_cmor_units = cmor_units
2776 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2777 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2779 fms_id = register_static_field_fms(module_name, cmor_field_name, &
2780 axes%handles, long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2781 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2782 standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, &
2783 interp_method=interp_method, tile_count=tile_count, area=area)
2784 if (fms_id /= diag_field_not_found)
then
2785 if (dm_id == -1)
then
2786 dm_id = get_new_diag_id(diag_cs)
2788 call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2789 cmor_diag%fms_diag_id = fms_id
2790 cmor_diag%debug_str = trim(module_name)//
"-"//trim(cmor_field_name)
2791 if (
present(conversion)) cmor_diag%conversion_factor = conversion
2792 if (
present(x_cell_method))
then
2793 call get_diag_axis_name(axes%handles(1), axis_name)
2794 call diag_field_add_attribute(fms_id,
'cell_methods', trim(axis_name)//
':'//trim(x_cell_method))
2796 if (
present(y_cell_method))
then
2797 call get_diag_axis_name(axes%handles(2), axis_name)
2798 call diag_field_add_attribute(fms_id,
'cell_methods', trim(axis_name)//
':'//trim(y_cell_method))
2800 if (
present(area_cell_method))
then
2801 call diag_field_add_attribute(fms_id,
'cell_methods',
'area:'//trim(area_cell_method))
2807 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2808 call log_available_diag(
associated(diag), module_name, field_name,
'',
'', diag_cs, &
2809 long_name, units, standard_name)
2810 if (
present(cmor_field_name))
then
2811 call log_available_diag(
associated(cmor_diag), module_name, cmor_field_name, &
2812 '',
'', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2813 posted_cmor_standard_name)
2817 register_static_field = dm_id
2819 end function register_static_field
2822 subroutine describe_option(opt_name, value, diag_CS)
2823 character(len=*),
intent(in) :: opt_name
2824 character(len=*),
intent(in) ::
value
2827 character(len=240) :: mesg
2830 len_ind = len_trim(
value)
2832 mesg =
" ! "//trim(opt_name)//
": "//trim(
value)
2833 write(diag_cs%available_diag_doc_unit,
'(a)') trim(mesg)
2834 end subroutine describe_option
2839 function ocean_register_diag(var_desc, G, diag_CS, day)
2840 integer :: ocean_register_diag
2841 type(
vardesc),
intent(in) :: var_desc
2843 type(
diag_ctrl),
intent(in),
target :: diag_cs
2844 type(time_type),
intent(in) :: day
2846 character(len=64) :: var_name
2847 character(len=48) :: units
2848 character(len=240) :: longname
2849 character(len=8) :: hor_grid, z_grid
2850 type(
axes_grp),
pointer :: axes => null()
2852 call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, &
2853 z_grid=z_grid, caller=
"ocean_register_diag")
2857 select case (z_grid)
2860 select case (hor_grid)
2862 axes => diag_cs%axesBL
2864 axes => diag_cs%axesTL
2866 axes => diag_cs%axesCuL
2868 axes => diag_cs%axesCvL
2870 axes => diag_cs%axesBL
2872 axes => diag_cs%axesTL
2874 axes => diag_cs%axesCuL
2876 axes => diag_cs%axesCvL
2878 axes => diag_cs%axeszL
2880 call mom_error(fatal,
"ocean_register_diag: " // &
2881 "unknown hor_grid component "//trim(hor_grid))
2885 select case (hor_grid)
2887 axes => diag_cs%axesBi
2889 axes => diag_cs%axesTi
2891 axes => diag_cs%axesCui
2893 axes => diag_cs%axesCvi
2895 axes => diag_cs%axesBi
2897 axes => diag_cs%axesTi
2899 axes => diag_cs%axesCui
2901 axes => diag_cs%axesCvi
2903 axes => diag_cs%axeszi
2905 call mom_error(fatal,
"ocean_register_diag: " // &
2906 "unknown hor_grid component "//trim(hor_grid))
2910 select case (hor_grid)
2912 axes => diag_cs%axesB1
2914 axes => diag_cs%axesT1
2916 axes => diag_cs%axesCu1
2918 axes => diag_cs%axesCv1
2920 axes => diag_cs%axesB1
2922 axes => diag_cs%axesT1
2924 axes => diag_cs%axesCu1
2926 axes => diag_cs%axesCv1
2928 call mom_error(fatal,
"ocean_register_diag: " // &
2929 "unknown hor_grid component "//trim(hor_grid))
2933 call mom_error(fatal,&
2934 "ocean_register_diag: unknown z_grid component "//trim(z_grid))
2937 ocean_register_diag = register_diag_field(
"ocean_model", trim(var_name), &
2938 axes, day, trim(longname), trim(units), missing_value=-1.0e+34)
2940 end function ocean_register_diag
2942 subroutine diag_mediator_infrastructure_init(err_msg)
2944 character(len=*),
optional,
intent(out) :: err_msg
2946 call diag_manager_init(err_msg=err_msg)
2947 end subroutine diag_mediator_infrastructure_init
2951 subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
2955 integer,
intent(in) :: nz
2957 type(
diag_ctrl),
intent(inout) :: diag_cs
2959 character(len=*),
optional,
intent(in) :: doc_file_dir
2965 integer :: ios, i, new_unit
2966 logical :: opened, new_file
2967 character(len=8) :: this_pe
2968 character(len=240) :: doc_file, doc_file_dflt, doc_path
2969 character(len=240),
allocatable :: diag_coords(:)
2971 #include "version_variable.h"
2972 character(len=40) :: mdl =
"MOM_diag_mediator"
2973 character(len=32) :: filename_appendix =
''
2975 id_clock_diag_mediator = cpu_clock_id(
'(Ocean diagnostics framework)', grain=clock_module)
2976 id_clock_diag_remap = cpu_clock_id(
'(Ocean diagnostics remapping)', grain=clock_routine)
2977 id_clock_diag_grid_updates = cpu_clock_id(
'(Ocean diagnostics grid updates)', grain=clock_routine)
2980 allocate(diag_cs%diags(diag_alloc_chunk_size))
2981 diag_cs%next_free_diag_id = 1
2982 do i=1, diag_alloc_chunk_size
2983 call initialize_diag_type(diag_cs%diags(i))
2989 call get_param(param_file, mdl,
'NUM_DIAG_COORDS', diag_cs%num_diag_coords, &
2990 'The number of diagnostic vertical coordinates to use. '//&
2991 'For each coordinate, an entry in DIAG_COORDS must be provided.', &
2993 if (diag_cs%num_diag_coords>0)
then
2994 allocate(diag_coords(diag_cs%num_diag_coords))
2995 if (diag_cs%num_diag_coords==1)
then
2996 call get_param(param_file, mdl,
'DIAG_COORDS', diag_coords, &
2997 'A list of string tuples associating diag_table modules to '//&
2998 'a coordinate definition used for diagnostics. Each string '//&
2999 'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', &
3000 default=
'z Z ZSTAR')
3002 call get_param(param_file, mdl,
'DIAG_COORDS', diag_coords, &
3003 'A list of string tuples associating diag_table modules to '//&
3004 'a coordinate definition used for diagnostics. Each string '//&
3005 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', &
3006 fail_if_missing=.true.)
3008 allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords))
3010 do i=1, diag_cs%num_diag_coords
3011 call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i))
3013 deallocate(diag_coords)
3016 call get_param(param_file, mdl,
'DIAG_MISVAL', diag_cs%missing_value, &
3017 'Set the default missing value to use for diagnostics.', &
3019 call get_param(param_file, mdl,
'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, &
3020 'Instead of writing diagnostics to the diag manager, write '//&
3021 'a text file containing the checksum (bitcount) of the array.', &
3024 if (diag_cs%diag_as_chksum) &
3025 diag_cs%num_chksum_diags = 0
3034 diag_cs%eqn_of_state => null()
3036 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3037 allocate(diag_cs%h_old(g%isd:g%ied,g%jsd:g%jed,nz))
3038 diag_cs%h_old(:,:,:) = 0.0
3041 diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
3042 diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
3043 diag_cs%isd = g%isd ; diag_cs%ied = g%ied
3044 diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
3047 diag_cs%dsamp(2)%isc = g%HId2%isc - (g%HId2%isd-1) ; diag_cs%dsamp(2)%iec = g%HId2%iec - (g%HId2%isd-1)
3048 diag_cs%dsamp(2)%jsc = g%HId2%jsc - (g%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = g%HId2%jec - (g%HId2%jsd-1)
3049 diag_cs%dsamp(2)%isd = g%HId2%isd ; diag_cs%dsamp(2)%ied = g%HId2%ied
3050 diag_cs%dsamp(2)%jsd = g%HId2%jsd ; diag_cs%dsamp(2)%jed = g%HId2%jed
3051 diag_cs%dsamp(2)%isg = g%HId2%isg ; diag_cs%dsamp(2)%ieg = g%HId2%ieg
3052 diag_cs%dsamp(2)%jsg = g%HId2%jsg ; diag_cs%dsamp(2)%jeg = g%HId2%jeg
3053 diag_cs%dsamp(2)%isgB = g%HId2%isgB ; diag_cs%dsamp(2)%iegB = g%HId2%iegB
3054 diag_cs%dsamp(2)%jsgB = g%HId2%jsgB ; diag_cs%dsamp(2)%jegB = g%HId2%jegB
3057 if (is_root_pe() .and. (diag_cs%available_diag_doc_unit < 0))
then
3058 write(this_pe,
'(i6.6)') pe_here()
3059 doc_file_dflt =
"available_diags."//this_pe
3060 call get_param(param_file, mdl,
"AVAILABLE_DIAGS_FILE", doc_file, &
3061 "A file into which to write a list of all available "//&
3062 "ocean diagnostics that can be included in a diag_table.", &
3063 default=doc_file_dflt, do_not_log=(diag_cs%available_diag_doc_unit/=-1))
3064 if (len_trim(doc_file) > 0)
then
3065 new_file = .true. ;
if (diag_cs%available_diag_doc_unit /= -1) new_file = .false.
3067 do new_unit=512,42,-1
3068 inquire( new_unit, opened=opened)
3069 if (.not.opened)
exit
3071 if (opened)
call mom_error(fatal, &
3072 "diag_mediator_init failed to find an unused unit number.")
3075 if (
present(doc_file_dir))
then ;
if (len_trim(doc_file_dir) > 0)
then
3076 doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3079 diag_cs%available_diag_doc_unit = new_unit
3082 open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3083 action=
'WRITE', status=
'REPLACE', iostat=ios)
3085 open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3086 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
3088 inquire(diag_cs%available_diag_doc_unit, opened=opened)
3089 if ((.not.opened) .or. (ios /= 0))
then
3090 call mom_error(fatal,
"Failed to open available diags file "//trim(doc_path)//
".")
3095 if (is_root_pe() .and. (diag_cs%chksum_iounit < 0) .and. diag_cs%diag_as_chksum)
then
3098 doc_file_dflt =
"chksum_diag"
3099 call get_param(param_file, mdl,
"CHKSUM_DIAG_FILE", doc_file, &
3100 "A file into which to write all checksums of the "//&
3101 "diagnostics listed in the diag_table.", &
3102 default=doc_file_dflt, do_not_log=(diag_cs%chksum_iounit/=-1))
3104 call get_filename_appendix(filename_appendix)
3105 if (len_trim(filename_appendix) > 0)
then
3106 doc_file = trim(doc_file) //
'.'//trim(filename_appendix)
3109 doc_file = trim(doc_file)//
"."//trim(adjustl(statslabel))
3112 if (len_trim(doc_file) > 0)
then
3113 new_file = .true. ;
if (diag_cs%chksum_iounit /= -1) new_file = .false.
3115 do new_unit=512,42,-1
3116 inquire( new_unit, opened=opened)
3117 if (.not.opened)
exit
3119 if (opened)
call mom_error(fatal, &
3120 "diag_mediator_init failed to find an unused unit number.")
3123 if (
present(doc_file_dir))
then ;
if (len_trim(doc_file_dir) > 0)
then
3124 doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3127 diag_cs%chksum_iounit = new_unit
3130 open(diag_cs%chksum_iounit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3131 action=
'WRITE', status=
'REPLACE', iostat=ios)
3133 open(diag_cs%chksum_iounit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3134 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
3136 inquire(diag_cs%chksum_iounit, opened=opened)
3137 if ((.not.opened) .or. (ios /= 0))
then
3138 call mom_error(fatal,
"Failed to open checksum diags file "//trim(doc_path)//
".")
3143 end subroutine diag_mediator_init
3146 subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs)
3147 real,
dimension(:,:,:),
target,
intent(in ) :: h
3148 real,
dimension(:,:,:),
target,
intent(in ) :: t
3149 real,
dimension(:,:,:),
target,
intent(in ) :: s
3150 type(
eos_type),
target,
intent(in ) :: eqn_of_state
3151 type(
diag_ctrl),
intent(inout) :: diag_cs
3157 diag_cs%eqn_of_state => eqn_of_state
3164 subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S)
3166 real,
target,
optional,
intent(in ) :: alt_h(:,:,:)
3168 real,
target,
optional,
intent(in ) :: alt_t(:,:,:)
3170 real,
target,
optional,
intent(in ) :: alt_s(:,:,:)
3174 real,
dimension(:,:,:),
pointer :: h_diag => null()
3175 real,
dimension(:,:,:),
pointer :: t_diag => null(), s_diag => null()
3177 if (
present(alt_h))
then
3183 if (
present(alt_t))
then
3189 if (
present(alt_s))
then
3195 if (id_clock_diag_grid_updates>0)
call cpu_clock_begin(id_clock_diag_grid_updates)
3197 if (diag_cs%diag_grid_overridden)
then
3198 call mom_error(fatal,
"diag_update_remap_grids was called, but current grids in "// &
3199 "diagnostic structure have been overridden")
3202 do i=1, diag_cs%num_diag_coords
3203 call diag_remap_update(diag_cs%diag_remap_cs(i), &
3204 diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, t_diag, s_diag, &
3205 diag_cs%eqn_of_state)
3208 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3211 diag_cs%h_old(:,:,:) = diag_cs%h(:,:,:)
3214 if (id_clock_diag_grid_updates>0)
call cpu_clock_end(id_clock_diag_grid_updates)
3216 end subroutine diag_update_remap_grids
3219 subroutine diag_masks_set(G, nz, diag_cs)
3221 integer,
intent(in) :: nz
3228 diag_cs%mask2dT => g%mask2dT
3229 diag_cs%mask2dBu => g%mask2dBu
3230 diag_cs%mask2dCu => g%mask2dCu
3231 diag_cs%mask2dCv => g%mask2dCv
3235 allocate(diag_cs%mask3dTL(g%isd:g%ied,g%jsd:g%jed,1:nz))
3236 allocate(diag_cs%mask3dBL(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz))
3237 allocate(diag_cs%mask3dCuL(g%IsdB:g%IedB,g%jsd:g%jed,1:nz))
3238 allocate(diag_cs%mask3dCvL(g%isd:g%ied,g%JsdB:g%JedB,1:nz))
3240 diag_cs%mask3dTL(:,:,k) = diag_cs%mask2dT(:,:)
3241 diag_cs%mask3dBL(:,:,k) = diag_cs%mask2dBu(:,:)
3242 diag_cs%mask3dCuL(:,:,k) = diag_cs%mask2dCu(:,:)
3243 diag_cs%mask3dCvL(:,:,k) = diag_cs%mask2dCv(:,:)
3245 allocate(diag_cs%mask3dTi(g%isd:g%ied,g%jsd:g%jed,1:nz+1))
3246 allocate(diag_cs%mask3dBi(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz+1))
3247 allocate(diag_cs%mask3dCui(g%IsdB:g%IedB,g%jsd:g%jed,1:nz+1))
3248 allocate(diag_cs%mask3dCvi(g%isd:g%ied,g%JsdB:g%JedB,1:nz+1))
3250 diag_cs%mask3dTi(:,:,k) = diag_cs%mask2dT(:,:)
3251 diag_cs%mask3dBi(:,:,k) = diag_cs%mask2dBu(:,:)
3252 diag_cs%mask3dCui(:,:,k) = diag_cs%mask2dCu(:,:)
3253 diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:)
3257 call downsample_diag_masks_set(g, nz, diag_cs)
3259 end subroutine diag_masks_set
3261 subroutine diag_mediator_close_registration(diag_CS)
3266 if (diag_cs%available_diag_doc_unit > -1)
then
3267 close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -2
3270 do i=1, diag_cs%num_diag_coords
3271 call diag_remap_diag_registration_closed(diag_cs%diag_remap_cs(i))
3274 end subroutine diag_mediator_close_registration
3276 subroutine diag_mediator_end(time, diag_CS, end_diag_manager)
3277 type(time_type),
intent(in) :: time
3278 type(
diag_ctrl),
intent(inout) :: diag_cs
3279 logical,
optional,
intent(in) :: end_diag_manager
3284 if (diag_cs%available_diag_doc_unit > -1)
then
3285 close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -3
3287 if (diag_cs%chksum_iounit > -1)
then
3288 close(diag_cs%chksum_iounit) ; diag_cs%chksum_iounit = -3
3291 deallocate(diag_cs%diags)
3293 do i=1, diag_cs%num_diag_coords
3294 call diag_remap_end(diag_cs%diag_remap_cs(i))
3297 call diag_grid_storage_end(diag_cs%diag_grid_temp)
3298 deallocate(diag_cs%mask3dTL)
3299 deallocate(diag_cs%mask3dBL)
3300 deallocate(diag_cs%mask3dCuL)
3301 deallocate(diag_cs%mask3dCvL)
3302 deallocate(diag_cs%mask3dTi)
3303 deallocate(diag_cs%mask3dBi)
3304 deallocate(diag_cs%mask3dCui)
3305 deallocate(diag_cs%mask3dCvi)
3306 do i=2,max_dsamp_lev
3307 deallocate(diag_cs%dsamp(i)%mask2dT)
3308 deallocate(diag_cs%dsamp(i)%mask2dBu)
3309 deallocate(diag_cs%dsamp(i)%mask2dCu)
3310 deallocate(diag_cs%dsamp(i)%mask2dCv)
3311 deallocate(diag_cs%dsamp(i)%mask3dTL)
3312 deallocate(diag_cs%dsamp(i)%mask3dBL)
3313 deallocate(diag_cs%dsamp(i)%mask3dCuL)
3314 deallocate(diag_cs%dsamp(i)%mask3dCvL)
3315 deallocate(diag_cs%dsamp(i)%mask3dTi)
3316 deallocate(diag_cs%dsamp(i)%mask3dBi)
3317 deallocate(diag_cs%dsamp(i)%mask3dCui)
3318 deallocate(diag_cs%dsamp(i)%mask3dCvi)
3321 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3322 deallocate(diag_cs%h_old)
3325 if (
present(end_diag_manager))
then
3326 if (end_diag_manager)
call diag_manager_end(time)
3329 end subroutine diag_mediator_end
3332 function i2s(a,n_in)
3335 integer,
dimension(:),
intent(in) :: a
3336 integer,
optional ,
intent(in) :: n_in
3337 character(len=15) :: i2s
3339 character(len=15) :: i2s_temp
3343 if (
present(n_in)) n = n_in
3347 write (i2s_temp,
'(I4.4)') a(i)
3348 i2s = trim(i2s) //
'_'// trim(i2s_temp)
3354 integer function get_new_diag_id(diag_cs)
3357 type(
diag_type),
dimension(:),
allocatable :: tmp
3360 if (diag_cs%next_free_diag_id >
size(diag_cs%diags))
then
3361 call assert(diag_cs%next_free_diag_id -
size(diag_cs%diags) == 1, &
3362 'get_new_diag_id: inconsistent diag id')
3366 allocate(tmp(
size(diag_cs%diags)))
3367 tmp(:) = diag_cs%diags(:)
3368 deallocate(diag_cs%diags)
3369 allocate(diag_cs%diags(
size(tmp) + diag_alloc_chunk_size))
3370 diag_cs%diags(1:
size(tmp)) = tmp(:)
3374 do i=diag_cs%next_free_diag_id,
size(diag_cs%diags)
3375 call initialize_diag_type(diag_cs%diags(i))
3379 get_new_diag_id = diag_cs%next_free_diag_id
3380 diag_cs%next_free_diag_id = diag_cs%next_free_diag_id + 1
3382 end function get_new_diag_id
3385 subroutine initialize_diag_type(diag)
3388 diag%in_use = .false.
3389 diag%fms_diag_id = -1
3392 diag%conversion_factor = 0.
3394 end subroutine initialize_diag_type
3398 subroutine alloc_diag_with_id(diag_id, diag_cs, diag)
3399 integer,
intent(in ) :: diag_id
3400 type(
diag_ctrl),
target,
intent(inout) :: diag_cs
3403 type(
diag_type),
pointer :: tmp => null()
3405 if (.not. diag_cs%diags(diag_id)%in_use)
then
3406 diag => diag_cs%diags(diag_id)
3409 tmp => diag_cs%diags(diag_id)%next
3410 diag_cs%diags(diag_id)%next => diag
3413 diag%in_use = .true.
3415 end subroutine alloc_diag_with_id
3418 subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, &
3419 diag_CS, long_name, units, standard_name)
3420 logical,
intent(in) :: used
3421 character(len=*),
intent(in) :: module_name
3422 character(len=*),
intent(in) :: field_name
3423 character(len=*),
intent(in) :: cell_methods_string
3424 character(len=*),
intent(in) :: comment
3426 character(len=*),
optional,
intent(in) :: long_name
3427 character(len=*),
optional,
intent(in) :: units
3428 character(len=*),
optional,
intent(in) :: standard_name
3430 character(len=240) :: mesg
3433 mesg =
'"'//trim(module_name)//
'", "'//trim(field_name)//
'" [Used]'
3435 mesg =
'"'//trim(module_name)//
'", "'//trim(field_name)//
'" [Unused]'
3437 if (len(trim((comment)))>0)
then
3438 write(diag_cs%available_diag_doc_unit,
'(a,x,"(",a,")")') trim(mesg),trim(comment)
3440 write(diag_cs%available_diag_doc_unit,
'(a)') trim(mesg)
3442 if (
present(long_name))
call describe_option(
"long_name", long_name, diag_cs)
3443 if (
present(units))
call describe_option(
"units", units, diag_cs)
3444 if (
present(standard_name)) &
3445 call describe_option(
"standard_name", standard_name, diag_cs)
3446 if (len(trim((cell_methods_string)))>0) &
3447 call describe_option(
"cell_methods", trim(cell_methods_string), diag_cs)
3449 end subroutine log_available_diag
3452 subroutine log_chksum_diag(docunit, description, chksum)
3453 integer,
intent(in) :: docunit
3454 character(len=*),
intent(in) :: description
3455 integer,
intent(in) :: chksum
3457 write(docunit,
'(a,x,i9.8)') description,
chksum
3460 end subroutine log_chksum_diag
3463 subroutine diag_grid_storage_init(grid_storage, G, diag)
3470 grid_storage%num_diag_coords = diag%num_diag_coords
3473 if (grid_storage%num_diag_coords < 1)
return
3476 allocate(grid_storage%h_state(g%isd:g%ied,g%jsd:g%jed, g%ke))
3478 allocate(grid_storage%diag_grids(diag%num_diag_coords))
3480 do m = 1, diag%num_diag_coords
3481 nz = diag%diag_remap_cs(m)%nz
3482 allocate(grid_storage%diag_grids(m)%h(g%isd:g%ied,g%jsd:g%jed, nz))
3485 end subroutine diag_grid_storage_init
3488 subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag)
3490 real,
dimension(:,:,:),
intent(in) :: h_state
3496 if (grid_storage%num_diag_coords < 1)
return
3498 grid_storage%h_state(:,:,:) = h_state(:,:,:)
3499 do m = 1,grid_storage%num_diag_coords
3500 if (diag%diag_remap_cs(m)%nz > 0) &
3501 grid_storage%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3504 end subroutine diag_copy_diag_to_storage
3507 subroutine diag_copy_storage_to_diag(diag, grid_storage)
3514 if (grid_storage%num_diag_coords < 1)
return
3516 diag%diag_grid_overridden = .true.
3517 do m = 1,grid_storage%num_diag_coords
3518 if (diag%diag_remap_cs(m)%nz > 0) &
3519 diag%diag_remap_cs(m)%h(:,:,:) = grid_storage%diag_grids(m)%h(:,:,:)
3522 end subroutine diag_copy_storage_to_diag
3525 subroutine diag_save_grids(diag)
3531 if (diag%num_diag_coords < 1)
return
3533 do m = 1,diag%num_diag_coords
3534 if (diag%diag_remap_cs(m)%nz > 0) &
3535 diag%diag_grid_temp%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3538 end subroutine diag_save_grids
3541 subroutine diag_restore_grids(diag)
3547 if (diag%num_diag_coords < 1)
return
3549 diag%diag_grid_overridden = .false.
3550 do m = 1,diag%num_diag_coords
3551 if (diag%diag_remap_cs(m)%nz > 0) &
3552 diag%diag_remap_cs(m)%h(:,:,:) = diag%diag_grid_temp%diag_grids(m)%h(:,:,:)
3555 end subroutine diag_restore_grids
3558 subroutine diag_grid_storage_end(grid_storage)
3564 if (grid_storage%num_diag_coords < 1)
return
3567 deallocate(grid_storage%h_state)
3569 do m = 1, grid_storage%num_diag_coords
3570 deallocate(grid_storage%diag_grids(m)%h)
3573 deallocate(grid_storage%diag_grids)
3574 end subroutine diag_grid_storage_end
3578 subroutine downsample_diag_masks_set(G, nz, diag_cs)
3580 integer,
intent(in) :: nz
3584 integer :: i,j,k,ii,jj,dl
3600 do dl=2,max_dsamp_lev
3602 call downsample_mask(g%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,g%isc, g%jsc, &
3603 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
3604 call downsample_mask(g%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,g%IscB,g%JscB, &
3605 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
3606 call downsample_mask(g%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,g%IscB,g%JscB, &
3607 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
3608 call downsample_mask(g%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,g%isc ,g%JscB, &
3609 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
3612 allocate(diag_cs%dsamp(dl)%mask3dTL(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz))
3613 allocate(diag_cs%dsamp(dl)%mask3dBL(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz))
3614 allocate(diag_cs%dsamp(dl)%mask3dCuL(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz))
3615 allocate(diag_cs%dsamp(dl)%mask3dCvL(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz))
3617 diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3618 diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3619 diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3620 diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3622 allocate(diag_cs%dsamp(dl)%mask3dTi(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz+1))
3623 allocate(diag_cs%dsamp(dl)%mask3dBi(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3624 allocate(diag_cs%dsamp(dl)%mask3dCui(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz+1))
3625 allocate(diag_cs%dsamp(dl)%mask3dCvi(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3627 diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3628 diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3629 diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3630 diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3633 end subroutine downsample_diag_masks_set
3637 subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev)
3638 integer,
intent(in) :: fo1
3639 integer,
intent(in) :: fo2
3640 integer,
intent(in) :: dl
3642 integer,
intent(out) :: isv
3643 integer,
intent(out) :: iev
3644 integer,
intent(out) :: jsv
3645 integer,
intent(out) :: jev
3647 integer :: dszi,cszi,dszj,cszj,f1,f2
3648 character(len=500) :: mesg
3649 logical,
save :: first_check = .true.
3657 if(first_check)
then
3658 if(mod(diag_cs%ie-diag_cs%is+1, dl) .ne. 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) .ne. 0)
then
3659 write (mesg,*)
"Non-commensurate downsampled domain is not supported. "//&
3660 "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,&
3661 " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je
3662 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3664 first_check = .false.
3667 cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1
3668 cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1
3669 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec
3670 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
3674 if (diag_cs%G%symmetric)
then
3675 f1 = f1 + mod(fo1,dl)
3676 f2 = f2 + mod(fo2,dl)
3678 if ( f1 == dszi )
then
3679 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec
3681 elseif ( f1 == dszi + 1 )
then
3682 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1
3683 elseif ( f1 == cszi)
then
3684 isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1
3685 elseif ( f1 == cszi + 1 )
then
3686 isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2
3688 write (mesg,*)
" peculiar size ",f1,
" in i-direction\n"//&
3689 "does not match one of ", cszi, cszi+1, dszi, dszi+1
3690 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3692 if ( f2 == dszj )
then
3693 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
3694 elseif ( f2 == dszj + 1 )
then
3695 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1
3696 elseif ( f2 == cszj)
then
3697 jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1
3698 elseif ( f2 == cszj + 1 )
then
3699 jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2
3701 write (mesg,*)
" peculiar size ",f2,
" in j-direction\n"//&
3702 "does not match one of ", cszj, cszj+1, dszj, dszj+1
3703 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3705 end subroutine downsample_diag_indices_get
3710 subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3711 real,
dimension(:,:,:),
pointer :: locfield
3712 real,
dimension(:,:,:),
allocatable,
intent(inout) :: locfield_dsamp
3715 integer,
intent(in) :: dl
3716 integer,
intent(inout) :: isv
3717 integer,
intent(inout) :: iev
3718 integer,
intent(inout) :: jsv
3719 integer,
intent(inout) :: jev
3720 real,
optional,
target,
intent(in) :: mask(:,:,:)
3722 real,
dimension(:,:,:),
pointer :: locmask
3723 integer :: f1,f2,isv_o,jsv_o
3733 call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3735 if (
present(mask))
then
3737 elseif (
associated(diag%axes%mask3d))
then
3738 locmask => diag%axes%mask3d
3740 call mom_error(fatal,
"downsample_diag_field_3d: Cannot downsample without a mask!!! ")
3743 call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, &
3744 isv_o,jsv_o,isv,iev,jsv,jev)
3746 end subroutine downsample_diag_field_3d
3751 subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3752 real,
dimension(:,:),
pointer :: locfield
3753 real,
dimension(:,:),
allocatable,
intent(inout) :: locfield_dsamp
3756 integer,
intent(in) :: dl
3757 integer,
intent(inout) :: isv
3758 integer,
intent(inout) :: iev
3759 integer,
intent(inout) :: jsv
3760 integer,
intent(inout) :: jev
3761 real,
optional,
target,
intent(in) :: mask(:,:)
3763 real,
dimension(:,:),
pointer :: locmask
3764 integer :: f1,f2,isv_o,jsv_o
3774 call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3776 if (
present(mask))
then
3778 elseif (
associated(diag%axes%mask2d))
then
3779 locmask => diag%axes%mask2d
3781 call mom_error(fatal,
"downsample_diag_field_2d: Cannot downsample without a mask!!! ")
3784 call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, &
3785 isv_o,jsv_o,isv,iev,jsv,jev)
3787 end subroutine downsample_diag_field_2d
3826 subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d)
3827 real,
dimension(:,:,:),
pointer :: field_in
3828 real,
dimension(:,:,:),
allocatable :: field_out
3829 integer,
intent(in) :: dl
3830 integer,
intent(in) :: method
3831 real,
dimension(:,:,:),
pointer :: mask
3834 integer,
intent(in) :: isv_o
3835 integer,
intent(in) :: jsv_o
3836 integer,
intent(in) :: isv_d
3837 integer,
intent(in) :: iev_d
3838 integer,
intent(in) :: jsv_d
3839 integer,
intent(in) :: jev_d
3841 character(len=240) :: mesg
3842 integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
3844 real :: ave,total_weight,weight
3845 real :: epsilon = 1.0e-20
3847 ks=1 ; ke =
size(field_in,3)
3851 f_in1 =
size(field_in,1)
3852 f_in2 =
size(field_in,2)
3856 if (diag_cs%G%symmetric)
then
3857 f1 = f1 + mod(f_in1,dl)
3858 f2 = f2 + mod(f_in2,dl)
3860 allocate(field_out(1:f1,1:f2,ks:ke))
3863 if(method .eq. mmm)
then
3864 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3865 i0 = isv_o+dl*(i-isv_d)
3866 j0 = jsv_o+dl*(j-jsv_d)
3869 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
3871 weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)*diag_cs%h(ii,jj,k)
3872 total_weight = total_weight + weight
3873 ave=ave+field_in(ii,jj,k)*weight
3875 field_out(i,j,k) = ave/(total_weight+epsilon)
3877 elseif(method .eq. sss)
then
3878 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3879 i0 = isv_o+dl*(i-isv_d)
3880 j0 = jsv_o+dl*(j-jsv_d)
3883 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
3885 weight = mask(ii,jj,k)
3886 total_weight = total_weight + weight
3887 ave=ave+field_in(ii,jj,k)*weight
3889 field_out(i,j,k) = ave/(total_weight+epsilon)
3891 elseif(method .eq. mmp .or. method .eq. mms)
then
3892 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3893 i0 = isv_o+dl*(i-isv_d)
3894 j0 = jsv_o+dl*(j-jsv_d)
3897 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
3899 weight = mask(ii,jj,k)*diag_cs%G%areaT(ii,jj)
3900 total_weight = total_weight + weight
3901 ave=ave+field_in(ii,jj,k)*weight
3903 field_out(i,j,k) = ave/(total_weight+epsilon)
3905 elseif(method .eq. pmm)
then
3906 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3907 i0 = isv_o+dl*(i-isv_d)
3908 j0 = jsv_o+dl*(j-jsv_d)
3913 weight =mask(ii,jj,k)*diag_cs%G%dyCu(ii,jj)*diag_cs%h(ii,jj,k)
3914 total_weight = total_weight +weight
3915 ave=ave+field_in(ii,jj,k)*weight
3917 field_out(i,j,k) = ave/(total_weight+epsilon)
3919 elseif(method .eq. psm)
then
3920 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3921 i0 = isv_o+dl*(i-isv_d)
3922 j0 = jsv_o+dl*(j-jsv_d)
3927 weight =mask(ii,jj,k)*diag_cs%h(ii,jj,k)
3928 total_weight = total_weight +weight
3929 ave=ave+field_in(ii,jj,k)*weight
3931 field_out(i,j,k) = ave/(total_weight+epsilon)
3933 elseif(method .eq. pss)
then
3934 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3935 i0 = isv_o+dl*(i-isv_d)
3936 j0 = jsv_o+dl*(j-jsv_d)
3941 weight =mask(ii,jj,k)
3942 total_weight = total_weight +weight
3943 ave=ave+field_in(ii,jj,k)*weight
3945 field_out(i,j,k) = ave/(total_weight+epsilon)
3947 elseif(method .eq. sps)
then
3948 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3949 i0 = isv_o+dl*(i-isv_d)
3950 j0 = jsv_o+dl*(j-jsv_d)
3955 weight =mask(ii,jj,k)
3956 total_weight = total_weight +weight
3957 ave=ave+field_in(ii,jj,k)*weight
3959 field_out(i,j,k) = ave/(total_weight+epsilon)
3961 elseif(method .eq. mpm)
then
3962 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3963 i0 = isv_o+dl*(i-isv_d)
3964 j0 = jsv_o+dl*(j-jsv_d)
3969 weight = mask(ii,jj,k)*diag_cs%G%dxCv(ii,jj)*diag_cs%h(ii,jj,k)
3970 total_weight = total_weight + weight
3971 ave=ave+field_in(ii,jj,k)*weight
3973 field_out(i,j,k) = ave/(total_weight+epsilon)
3975 elseif(method .eq. msk)
then
3976 field_out(:,:,:) = 0.0
3977 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3978 i0 = isv_o+dl*(i-isv_d)
3979 j0 = jsv_o+dl*(j-jsv_d)
3981 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
3982 ave=ave+field_in(ii,jj,k)
3984 if(ave > 0.0) field_out(i,j,k)=1.0
3987 write (mesg,*)
" unknown sampling method: ",method
3988 call mom_error(fatal,
"downsample_field_3d: "//trim(mesg)//
" "//trim(diag%debug_str))
3991 end subroutine downsample_field_3d
3996 subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, &
3997 isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d)
3998 real,
dimension(:,:),
pointer :: field_in
3999 real,
dimension(:,:),
allocatable :: field_out
4000 integer,
intent(in) :: dl
4001 integer,
intent(in) :: method
4002 real,
dimension(:,:),
pointer :: mask
4005 integer,
intent(in) :: isv_o
4006 integer,
intent(in) :: jsv_o
4007 integer,
intent(in) :: isv_d
4008 integer,
intent(in) :: iev_d
4009 integer,
intent(in) :: jsv_d
4010 integer,
intent(in) :: jev_d
4012 character(len=240) :: mesg
4013 integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
4014 real :: ave,total_weight,weight
4015 real :: epsilon = 1.0e-20
4021 f_in1 =
size(field_in,1)
4022 f_in2 =
size(field_in,2)
4026 if (diag_cs%G%symmetric)
then
4027 f1 = f1 + mod(f_in1,dl)
4028 f2 = f2 + mod(f_in2,dl)
4030 allocate(field_out(1:f1,1:f2))
4032 if(method .eq. mmp)
then
4033 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4034 i0 = isv_o+dl*(i-isv_d)
4035 j0 = jsv_o+dl*(j-jsv_d)
4038 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4040 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)
4041 total_weight = total_weight + weight
4042 ave=ave+field_in(ii,jj)*weight
4044 field_out(i,j) = ave/(total_weight+epsilon)
4046 elseif(method .eq. ssp)
then
4047 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4048 i0 = isv_o+dl*(i-isv_d)
4049 j0 = jsv_o+dl*(j-jsv_d)
4052 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4054 weight = mask(ii,jj)
4055 total_weight = total_weight + weight
4056 ave=ave+field_in(ii,jj)*weight
4058 field_out(i,j) = ave/(total_weight+epsilon)
4060 elseif(method .eq. psp)
then
4061 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4062 i0 = isv_o+dl*(i-isv_d)
4063 j0 = jsv_o+dl*(j-jsv_d)
4069 total_weight = total_weight +weight
4070 ave=ave+field_in(ii,jj)*weight
4072 field_out(i,j) = ave/(total_weight+epsilon)
4074 elseif(method .eq. spp)
then
4075 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4076 i0 = isv_o+dl*(i-isv_d)
4077 j0 = jsv_o+dl*(j-jsv_d)
4083 total_weight = total_weight +weight
4084 ave=ave+field_in(ii,jj)*weight
4086 field_out(i,j) = ave/(total_weight+epsilon)
4088 elseif(method .eq. pmp)
then
4089 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4090 i0 = isv_o+dl*(i-isv_d)
4091 j0 = jsv_o+dl*(j-jsv_d)
4096 weight =mask(ii,jj)*diag_cs%G%dyCu(ii,jj)
4097 total_weight = total_weight +weight
4098 ave=ave+field_in(ii,jj)*weight
4100 field_out(i,j) = ave/(total_weight+epsilon)
4102 elseif(method .eq. mpp)
then
4103 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4104 i0 = isv_o+dl*(i-isv_d)
4105 j0 = jsv_o+dl*(j-jsv_d)
4110 weight =mask(ii,jj)*diag_cs%G%dxCv(ii,jj)
4111 total_weight = total_weight +weight
4112 ave=ave+field_in(ii,jj)*weight
4114 field_out(i,j) = ave/(total_weight+epsilon)
4116 elseif(method .eq. msk)
then
4117 field_out(:,:) = 0.0
4118 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4119 i0 = isv_o+dl*(i-isv_d)
4120 j0 = jsv_o+dl*(j-jsv_d)
4122 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4123 ave=ave+field_in(ii,jj)
4125 if(ave > 0.0) field_out(i,j)=1.0
4128 write (mesg,*)
" unknown sampling method: ",method
4129 call mom_error(fatal,
"downsample_field_2d: "//trim(mesg)//
" "//trim(diag%debug_str))
4132 end subroutine downsample_field_2d
4137 subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4138 isd_d, ied_d, jsd_d, jed_d)
4139 real,
dimension(:,:),
intent(in) :: field_in
4140 real,
dimension(:,:),
pointer :: field_out
4141 integer,
intent(in) :: dl
4142 integer,
intent(in) :: isc_o
4143 integer,
intent(in) :: jsc_o
4144 integer,
intent(in) :: isc_d
4145 integer,
intent(in) :: iec_d
4146 integer,
intent(in) :: jsc_d
4147 integer,
intent(in) :: jec_d
4148 integer,
intent(in) :: isd_d
4149 integer,
intent(in) :: ied_d
4150 integer,
intent(in) :: jsd_d
4151 integer,
intent(in) :: jed_d
4153 integer :: i,j,ii,jj,i0,j0
4154 real :: tot_non_zero
4156 allocate(field_out(isd_d:ied_d,jsd_d:jed_d))
4157 field_out(:,:) = 0.0
4158 do j=jsc_d,jec_d ;
do i=isc_d,iec_d
4159 i0 = isc_o+dl*(i-isc_d)
4160 j0 = jsc_o+dl*(j-jsc_d)
4162 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4163 tot_non_zero = tot_non_zero + field_in(ii,jj)
4165 if(tot_non_zero > 0.0) field_out(i,j)=1.0
4167 end subroutine downsample_mask_2d
4172 subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4173 isd_d, ied_d, jsd_d, jed_d)
4174 real,
dimension(:,:,:),
intent(in) :: field_in
4175 real,
dimension(:,:,:),
pointer :: field_out
4176 integer,
intent(in) :: dl
4177 integer,
intent(in) :: isc_o
4178 integer,
intent(in) :: jsc_o
4179 integer,
intent(in) :: isc_d
4180 integer,
intent(in) :: iec_d
4181 integer,
intent(in) :: jsc_d
4182 integer,
intent(in) :: jec_d
4183 integer,
intent(in) :: isd_d
4184 integer,
intent(in) :: ied_d
4185 integer,
intent(in) :: jsd_d
4186 integer,
intent(in) :: jed_d
4188 integer :: i,j,ii,jj,i0,j0,k,ks,ke
4189 real :: tot_non_zero
4191 ks = lbound(field_in,3) ; ke = ubound(field_in,3)
4192 allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke))
4193 field_out(:,:,:) = 0.0
4194 do k= ks,ke ;
do j=jsc_d,jec_d ;
do i=isc_d,iec_d
4195 i0 = isc_o+dl*(i-isc_d)
4196 j0 = jsc_o+dl*(j-jsc_d)
4198 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4199 tot_non_zero = tot_non_zero + field_in(ii,jj,k)
4201 if(tot_non_zero > 0.0) field_out(i,j,k)=1.0
4203 end subroutine downsample_mask_3d