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, east, north, 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, enable_averages, 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
182 integer :: fms_diag_id
183 integer :: fms_xyave_diag_id = -1
184 integer :: downsample_diag_id = -1
185 character(64) :: debug_str =
''
188 real :: conversion_factor = 0.
189 logical :: v_extensive = .false.
191 integer :: xyz_method = 0
218 type(
axes_grp),
dimension(:),
allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
219 type(
axes_grp),
dimension(:),
allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
222 real,
dimension(:,:),
pointer :: mask2dt => null()
223 real,
dimension(:,:),
pointer :: mask2dbu => null()
224 real,
dimension(:,:),
pointer :: mask2dcu => null()
225 real,
dimension(:,:),
pointer :: mask2dcv => null()
227 real,
dimension(:,:,:),
pointer :: mask3dtl => null()
228 real,
dimension(:,:,:),
pointer :: mask3dbl => null()
229 real,
dimension(:,:,:),
pointer :: mask3dcul => null()
230 real,
dimension(:,:,:),
pointer :: mask3dcvl => null()
231 real,
dimension(:,:,:),
pointer :: mask3dti => null()
232 real,
dimension(:,:,:),
pointer :: mask3dbi => null()
233 real,
dimension(:,:,:),
pointer :: mask3dcui => null()
234 real,
dimension(:,:,:),
pointer :: mask3dcvi => null()
241 integer :: available_diag_doc_unit = -1
243 integer :: chksum_iounit = -1
245 logical :: diag_as_chksum
246 logical :: grid_space_axes
259 type(time_type) :: time_end
261 logical :: ave_enabled = .false.
273 real,
dimension(:,:),
pointer :: mask2dt => null()
274 real,
dimension(:,:),
pointer :: mask2dbu => null()
275 real,
dimension(:,:),
pointer :: mask2dcu => null()
276 real,
dimension(:,:),
pointer :: mask2dcv => null()
278 real,
dimension(:,:,:),
pointer :: mask3dtl => null()
279 real,
dimension(:,:,:),
pointer :: mask3dbl => null()
280 real,
dimension(:,:,:),
pointer :: mask3dcul => null()
281 real,
dimension(:,:,:),
pointer :: mask3dcvl => null()
282 real,
dimension(:,:,:),
pointer :: mask3dti => null()
283 real,
dimension(:,:,:),
pointer :: mask3dbi => null()
284 real,
dimension(:,:,:),
pointer :: mask3dcui => null()
285 real,
dimension(:,:,:),
pointer :: mask3dcvi => null()
293 #define DIAG_ALLOC_CHUNK_SIZE 100
295 integer :: next_free_diag_id
298 real :: missing_value = -1.0e+34
301 integer :: num_diag_coords
305 logical :: diag_grid_overridden = .false.
308 remap_axeszl, & !< The 1-D z-space cell-centered axis for remapping
311 type(
axes_grp),
dimension(:),
allocatable :: remap_axestl, remap_axesbl, remap_axescul, remap_axescvl
312 type(
axes_grp),
dimension(:),
allocatable :: remap_axesti, remap_axesbi, remap_axescui, remap_axescvi
316 real,
dimension(:,:,:),
pointer :: h => null()
317 real,
dimension(:,:,:),
pointer :: t => null()
318 real,
dimension(:,:,:),
pointer :: s => null()
325 integer :: volume_cell_measure_dm_id = -1
327 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
330 real,
dimension(:,:,:),
allocatable :: h_old
334 integer :: num_chksum_diags
336 real,
dimension(:,:,:),
allocatable :: h_begin
342 integer :: id_clock_diag_mediator, id_clock_diag_remap, id_clock_diag_grid_updates
348 subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical)
353 type(
diag_ctrl),
intent(inout) :: diag_cs
354 logical,
optional,
intent(in) :: set_vertical
357 integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
358 integer :: id_zl_native, id_zi_native
359 integer :: i, j, k, nz
360 real :: zlev(gv%ke), zinter(gv%ke+1)
362 real,
allocatable,
dimension(:) :: iaxb,iax
363 real,
allocatable,
dimension(:) :: jaxb,jax
366 set_vert = .true. ;
if (
present(set_vertical)) set_vert = set_vertical
369 if (diag_cs%grid_space_axes)
then
370 allocate(iaxb(g%IsgB:g%IegB))
374 allocate(iax(g%isg:g%ieg))
378 allocate(jaxb(g%JsgB:g%JegB))
382 allocate(jax(g%jsg:g%jeg))
389 if (g%symmetric)
then
390 if (diag_cs%grid_space_axes)
then
391 id_xq = diag_axis_init(
'iq', iaxb(g%isgB:g%iegB),
'none',
'x', &
392 'q point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
393 id_yq = diag_axis_init(
'jq', jaxb(g%jsgB:g%jegB),
'none',
'y', &
394 'q point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
396 id_xq = diag_axis_init(
'xq', g%gridLonB(g%isgB:g%iegB), g%x_axis_units,
'x', &
397 'q point nominal longitude', domain2=g%Domain%mpp_domain, domain_position=east)
398 id_yq = diag_axis_init(
'yq', g%gridLatB(g%jsgB:g%jegB), g%y_axis_units,
'y', &
399 'q point nominal latitude', domain2=g%Domain%mpp_domain, domain_position=north)
402 if (diag_cs%grid_space_axes)
then
403 id_xq = diag_axis_init(
'Iq', iaxb(g%isg:g%ieg),
'none',
'x', &
404 'q point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
405 id_yq = diag_axis_init(
'Jq', jaxb(g%jsg:g%jeg),
'none',
'y', &
406 'q point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
408 id_xq = diag_axis_init(
'xq', g%gridLonB(g%isg:g%ieg), g%x_axis_units,
'x', &
409 'q point nominal longitude', domain2=g%Domain%mpp_domain, domain_position=east)
410 id_yq = diag_axis_init(
'yq', g%gridLatB(g%jsg:g%jeg), g%y_axis_units,
'y', &
411 'q point nominal latitude', domain2=g%Domain%mpp_domain, domain_position=north)
416 if (diag_cs%grid_space_axes)
then
417 id_xh = diag_axis_init(
'ih', iax(g%isg:g%ieg),
'none',
'x', &
418 'h point grid-space longitude', domain2=g%Domain%mpp_domain, domain_position=east)
419 id_yh = diag_axis_init(
'jh', jax(g%jsg:g%jeg),
'none',
'y', &
420 'h point grid space latitude', domain2=g%Domain%mpp_domain, domain_position=north)
422 id_xh = diag_axis_init(
'xh', g%gridLonT(g%isg:g%ieg), g%x_axis_units,
'x', &
423 'h point nominal longitude', domain2=g%Domain%mpp_domain)
424 id_yh = diag_axis_init(
'yh', g%gridLatT(g%jsg:g%jeg), g%y_axis_units,
'y', &
425 'h point nominal latitude', domain2=g%Domain%mpp_domain)
430 zinter(1:nz+1) = gv%sInterface(1:nz+1)
431 zlev(1:nz) = gv%sLayer(1:nz)
432 id_zl = diag_axis_init(
'zl', zlev, trim(gv%zAxisUnits),
'z', &
433 'Layer '//trim(gv%zAxisLongName), &
434 direction=gv%direction)
435 id_zi = diag_axis_init(
'zi', zinter, trim(gv%zAxisUnits),
'z', &
436 'Interface '//trim(gv%zAxisLongName), &
437 direction=gv%direction)
439 id_zl = -1 ; id_zi = -1
441 id_zl_native = id_zl ; id_zi_native = id_zi
443 call define_axes_group(diag_cs, (/ id_zi /), diag_cs%axesZi, &
444 v_cell_method=
'point', is_interface=.true.)
445 call define_axes_group(diag_cs, (/ id_zl /), diag_cs%axesZL, &
446 v_cell_method=
'mean', is_layer=.true.)
449 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%axesTL, &
450 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
451 is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
452 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%axesBL, &
453 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
454 is_q_point=.true., is_layer=.true.)
455 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%axesCuL, &
456 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
457 is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
458 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%axesCvL, &
459 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
460 is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
463 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%axesTi, &
464 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
465 is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
466 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%axesBi, &
467 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
468 is_q_point=.true., is_interface=.true.)
469 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%axesCui, &
470 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
471 is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
472 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%axesCvi, &
473 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
474 is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
477 call define_axes_group(diag_cs, (/ id_xh, id_yh /), diag_cs%axesT1, &
478 x_cell_method=
'mean', y_cell_method=
'mean', is_h_point=.true.)
479 call define_axes_group(diag_cs, (/ id_xq, id_yq /), diag_cs%axesB1, &
480 x_cell_method=
'point', y_cell_method=
'point', is_q_point=.true.)
481 call define_axes_group(diag_cs, (/ id_xq, id_yh /), diag_cs%axesCu1, &
482 x_cell_method=
'point', y_cell_method=
'mean', is_u_point=.true.)
483 call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, &
484 x_cell_method=
'mean', y_cell_method=
'point', is_v_point=.true.)
487 call define_axes_group(diag_cs, (/ null_axis_id /), diag_cs%axesNull)
491 if (diag_cs%num_diag_coords>0)
then
492 allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords))
493 allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords))
494 allocate(diag_cs%remap_axesBL(diag_cs%num_diag_coords))
495 allocate(diag_cs%remap_axesCuL(diag_cs%num_diag_coords))
496 allocate(diag_cs%remap_axesCvL(diag_cs%num_diag_coords))
497 allocate(diag_cs%remap_axesZi(diag_cs%num_diag_coords))
498 allocate(diag_cs%remap_axesTi(diag_cs%num_diag_coords))
499 allocate(diag_cs%remap_axesBi(diag_cs%num_diag_coords))
500 allocate(diag_cs%remap_axesCui(diag_cs%num_diag_coords))
501 allocate(diag_cs%remap_axesCvi(diag_cs%num_diag_coords))
504 do i=1, diag_cs%num_diag_coords
506 call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), gv, us, param_file)
509 allocate(diag_cs%diag_remap_cs(i)%h(g%isd:g%ied,g%jsd:g%jed, diag_cs%diag_remap_cs(i)%nz))
510 allocate(diag_cs%diag_remap_cs(i)%h_extensive(g%isd:g%ied,g%jsd:g%jed, diag_cs%diag_remap_cs(i)%nz))
513 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i)))
then
517 call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
520 call define_axes_group(diag_cs, (/ id_zl /), diag_cs%remap_axesZL(i), &
521 nz=nz, vertical_coordinate_number=i, &
522 v_cell_method=
'mean', &
523 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true.)
524 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%remap_axesTL(i), &
525 nz=nz, vertical_coordinate_number=i, &
526 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
527 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
528 xyave_axes=diag_cs%remap_axesZL(i))
532 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%remap_axesBL(i), &
533 nz=nz, vertical_coordinate_number=i, &
534 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
535 is_q_point=.true., is_layer=.true., is_native=.false.)
537 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%remap_axesCuL(i), &
538 nz=nz, vertical_coordinate_number=i, &
539 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
540 is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
541 xyave_axes=diag_cs%remap_axesZL(i))
543 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%remap_axesCvL(i), &
544 nz=nz, vertical_coordinate_number=i, &
545 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
546 is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
547 xyave_axes=diag_cs%remap_axesZL(i))
550 call define_axes_group(diag_cs, (/ id_zi /), diag_cs%remap_axesZi(i), &
551 nz=nz, vertical_coordinate_number=i, &
552 v_cell_method=
'point', &
553 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true.)
554 call define_axes_group(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%remap_axesTi(i), &
555 nz=nz, vertical_coordinate_number=i, &
556 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
557 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
558 xyave_axes=diag_cs%remap_axesZi(i))
561 call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%remap_axesBi(i), &
562 nz=nz, vertical_coordinate_number=i, &
563 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
564 is_q_point=.true., is_interface=.true., is_native=.false.)
566 call define_axes_group(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%remap_axesCui(i), &
567 nz=nz, vertical_coordinate_number=i, &
568 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
569 is_u_point=.true., is_interface=.true., is_native=.false., &
570 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
572 call define_axes_group(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%remap_axesCvi(i), &
573 nz=nz, vertical_coordinate_number=i, &
574 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
575 is_v_point=.true., is_interface=.true., is_native=.false., &
576 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
580 if (diag_cs%grid_space_axes)
then
581 deallocate(iaxb,iax,jaxb,jax)
584 call set_axes_info_dsamp(g, gv, param_file, diag_cs, id_zl_native, id_zi_native)
586 call diag_grid_storage_init(diag_cs%diag_grid_temp, g, diag_cs)
588 end subroutine set_axes_info
590 subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native)
594 type(
diag_ctrl),
intent(inout) :: diag_cs
595 integer,
intent(in) :: id_zl_native
596 integer,
intent(in) :: id_zi_native
599 integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh
600 integer :: i, j, k, nz, dl
601 real,
dimension(:),
pointer :: gridLonT_dsamp =>null()
602 real,
dimension(:),
pointer :: gridLatT_dsamp =>null()
603 real,
dimension(:),
pointer :: gridLonB_dsamp =>null()
604 real,
dimension(:),
pointer :: gridLatB_dsamp =>null()
606 id_zl = id_zl_native ; id_zi = id_zi_native
608 do dl=2,max_dsamp_lev
609 if(dl .ne. 2)
call mom_error(fatal,
"set_axes_info_dsamp: Downsample level other than 2 is not supported yet!")
610 if (g%symmetric)
then
611 allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB))
612 allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB))
613 do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridlonb_dsamp(i) = g%gridLonB(g%isgB+dl*i);
enddo
614 do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridlatb_dsamp(j) = g%gridLatB(g%jsgB+dl*j);
enddo
615 id_xq = diag_axis_init(
'xq', gridlonb_dsamp, g%x_axis_units,
'x', &
616 'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
617 id_yq = diag_axis_init(
'yq', gridlatb_dsamp, g%y_axis_units,
'y', &
618 'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
619 deallocate(gridlonb_dsamp,gridlatb_dsamp)
621 allocate(gridlonb_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
622 allocate(gridlatb_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
623 do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlonb_dsamp(i) = g%gridLonB(g%isg+dl*i-2);
enddo
624 do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatb_dsamp(j) = g%gridLatB(g%jsg+dl*j-2);
enddo
625 id_xq = diag_axis_init(
'xq', gridlonb_dsamp, g%x_axis_units,
'x', &
626 'q point nominal longitude', domain2=g%Domain%mpp_domain_d2)
627 id_yq = diag_axis_init(
'yq', gridlatb_dsamp, g%y_axis_units,
'y', &
628 'q point nominal latitude', domain2=g%Domain%mpp_domain_d2)
629 deallocate(gridlonb_dsamp,gridlatb_dsamp)
632 allocate(gridlont_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg))
633 allocate(gridlatt_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg))
634 do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridlont_dsamp(i) = g%gridLonT(g%isg+dl*i-2);
enddo
635 do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridlatt_dsamp(j) = g%gridLatT(g%jsg+dl*j-2);
enddo
636 id_xh = diag_axis_init(
'xh', gridlont_dsamp, g%x_axis_units,
'x', &
637 'h point nominal longitude', domain2=g%Domain%mpp_domain_d2)
638 id_yh = diag_axis_init(
'yh', gridlatt_dsamp, g%y_axis_units,
'y', &
639 'h point nominal latitude', domain2=g%Domain%mpp_domain_d2)
641 deallocate(gridlont_dsamp,gridlatt_dsamp)
644 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%axesTL, dl, &
645 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
646 is_h_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
647 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%axesBL, dl, &
648 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
649 is_q_point=.true., is_layer=.true.)
650 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%axesCuL, dl, &
651 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
652 is_u_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
653 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%axesCvL, dl, &
654 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
655 is_v_point=.true., is_layer=.true., xyave_axes=diag_cs%axesZL)
658 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%axesTi, dl, &
659 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
660 is_h_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
661 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%axesBi, dl, &
662 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
663 is_q_point=.true., is_interface=.true.)
664 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%axesCui, dl, &
665 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
666 is_u_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
667 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%axesCvi, dl, &
668 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
669 is_v_point=.true., is_interface=.true., xyave_axes=diag_cs%axesZi)
672 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh /), diag_cs%dsamp(dl)%axesT1, dl, &
673 x_cell_method=
'mean', y_cell_method=
'mean', is_h_point=.true.)
674 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq /), diag_cs%dsamp(dl)%axesB1, dl, &
675 x_cell_method=
'point', y_cell_method=
'point', is_q_point=.true.)
676 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh /), diag_cs%dsamp(dl)%axesCu1, dl, &
677 x_cell_method=
'point', y_cell_method=
'mean', is_u_point=.true.)
678 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, &
679 x_cell_method=
'mean', y_cell_method=
'point', is_v_point=.true.)
682 if (diag_cs%num_diag_coords>0)
then
683 allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords))
684 allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords))
685 allocate(diag_cs%dsamp(dl)%remap_axesCuL(diag_cs%num_diag_coords))
686 allocate(diag_cs%dsamp(dl)%remap_axesCvL(diag_cs%num_diag_coords))
687 allocate(diag_cs%dsamp(dl)%remap_axesTi(diag_cs%num_diag_coords))
688 allocate(diag_cs%dsamp(dl)%remap_axesBi(diag_cs%num_diag_coords))
689 allocate(diag_cs%dsamp(dl)%remap_axesCui(diag_cs%num_diag_coords))
690 allocate(diag_cs%dsamp(dl)%remap_axesCvi(diag_cs%num_diag_coords))
693 do i=1, diag_cs%num_diag_coords
698 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i)))
then
702 call diag_remap_get_axes_info(diag_cs%diag_remap_cs(i), nz, id_zl, id_zi)
705 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesTL(i), dl, &
706 nz=nz, vertical_coordinate_number=i, &
707 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'mean', &
708 is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
709 xyave_axes=diag_cs%remap_axesZL(i))
713 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesBL(i), dl, &
714 nz=nz, vertical_coordinate_number=i, &
715 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'mean', &
716 is_q_point=.true., is_layer=.true., is_native=.false.)
718 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zl /), diag_cs%dsamp(dl)%remap_axesCuL(i), dl, &
719 nz=nz, vertical_coordinate_number=i, &
720 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'mean', &
721 is_u_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
722 xyave_axes=diag_cs%remap_axesZL(i))
724 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zl /), diag_cs%dsamp(dl)%remap_axesCvL(i), dl, &
725 nz=nz, vertical_coordinate_number=i, &
726 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'mean', &
727 is_v_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., &
728 xyave_axes=diag_cs%remap_axesZL(i))
731 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesTi(i), dl, &
732 nz=nz, vertical_coordinate_number=i, &
733 x_cell_method=
'mean', y_cell_method=
'mean', v_cell_method=
'point', &
734 is_h_point=.true., is_interface=.true., is_native=.false., needs_interpolating=.true., &
735 xyave_axes=diag_cs%remap_axesZi(i))
738 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesBi(i), dl, &
739 nz=nz, vertical_coordinate_number=i, &
740 x_cell_method=
'point', y_cell_method=
'point', v_cell_method=
'point', &
741 is_q_point=.true., is_interface=.true., is_native=.false.)
743 call define_axes_group_dsamp(diag_cs, (/ id_xq, id_yh, id_zi /), diag_cs%dsamp(dl)%remap_axesCui(i), dl, &
744 nz=nz, vertical_coordinate_number=i, &
745 x_cell_method=
'point', y_cell_method=
'mean', v_cell_method=
'point', &
746 is_u_point=.true., is_interface=.true., is_native=.false., &
747 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
749 call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq, id_zi /), diag_cs%dsamp(dl)%remap_axesCvi(i), dl, &
750 nz=nz, vertical_coordinate_number=i, &
751 x_cell_method=
'mean', y_cell_method=
'point', v_cell_method=
'point', &
752 is_v_point=.true., is_interface=.true., is_native=.false., &
753 needs_interpolating=.true., xyave_axes=diag_cs%remap_axesZi(i))
758 end subroutine set_axes_info_dsamp
763 subroutine set_masks_for_axes(G, diag_cs)
768 integer :: c, nk, i, j, k, ii, jj
769 type(
axes_grp),
pointer :: axes => null(), h_axes => null()
771 do c=1, diag_cs%num_diag_coords
773 if (diag_remap_axes_configured(diag_cs%diag_remap_cs(c)))
then
776 axes => diag_cs%remap_axesTL(c)
778 allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
779 call diag_remap_calc_hmask(diag_cs%diag_remap_cs(c), g, axes%mask3d)
781 h_axes => diag_cs%remap_axesTL(c)
784 axes => diag_cs%remap_axesCuL(c)
785 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at u-layers')
786 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
787 allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk) ) ; axes%mask3d(:,:,:) = 0.
788 do k = 1, nk ;
do j=g%jsc,g%jec ;
do i=g%isc-1,g%iec
789 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
790 enddo ;
enddo ;
enddo
793 axes => diag_cs%remap_axesCvL(c)
794 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at v-layers')
795 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
796 allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
797 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc,g%iec
798 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
799 enddo ;
enddo ;
enddo
802 axes => diag_cs%remap_axesBL(c)
803 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at q-layers')
804 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
805 allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk) ) ; axes%mask3d(:,:,:) = 0.
806 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc-1,g%iec
807 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
808 h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
809 enddo ;
enddo ;
enddo
812 axes => diag_cs%remap_axesTi(c)
813 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at h-interfaces')
814 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
815 allocate( axes%mask3d(g%isd:g%ied,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
816 do j=g%jsc-1,g%jec+1 ;
do i=g%isc-1,g%iec+1
817 if (h_axes%mask3d(i,j,1) > 0.) axes%mask3d(i,j,1) = 1.
819 if (h_axes%mask3d(i,j,k-1) + h_axes%mask3d(i,j,k) > 0.) axes%mask3d(i,j,k) = 1.
821 if (h_axes%mask3d(i,j,nk) > 0.) axes%mask3d(i,j,nk+1) = 1.
824 h_axes => diag_cs%remap_axesTi(c)
827 axes => diag_cs%remap_axesCui(c)
828 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at u-interfaces')
829 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
830 allocate( axes%mask3d(g%IsdB:g%IedB,g%jsd:g%jed,nk+1) ) ; axes%mask3d(:,:,:) = 0.
831 do k = 1, nk+1 ;
do j=g%jsc,g%jec ;
do i=g%isc-1,g%iec
832 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j,k) > 0.) axes%mask3d(i,j,k) = 1.
833 enddo ;
enddo ;
enddo
836 axes => diag_cs%remap_axesCvi(c)
837 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at v-interfaces')
838 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
839 allocate( axes%mask3d(g%isd:g%ied,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
840 do k = 1, nk+1 ;
do j=g%jsc-1,g%jec ;
do i=g%isc,g%iec
841 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
842 enddo ;
enddo ;
enddo
845 axes => diag_cs%remap_axesBi(c)
846 call assert(axes%nz == nk,
'set_masks_for_axes: vertical size mismatch at q-interfaces')
847 call assert(.not.
associated(axes%mask3d),
'set_masks_for_axes: already associated')
848 allocate( axes%mask3d(g%IsdB:g%IedB,g%JsdB:g%JedB,nk+1) ) ; axes%mask3d(:,:,:) = 0.
849 do k = 1, nk ;
do j=g%jsc-1,g%jec ;
do i=g%isc-1,g%iec
850 if (h_axes%mask3d(i,j,k) + h_axes%mask3d(i+1,j+1,k) + &
851 h_axes%mask3d(i+1,j,k) + h_axes%mask3d(i,j+1,k) > 0.) axes%mask3d(i,j,k) = 1.
852 enddo ;
enddo ;
enddo
857 call set_masks_for_axes_dsamp(g, diag_cs)
859 end subroutine set_masks_for_axes
861 subroutine set_masks_for_axes_dsamp(G, diag_cs)
866 integer :: c, nk, i, j, k, ii, jj
868 type(
axes_grp),
pointer :: axes => null(), h_axes => null()
873 do dl=2,max_dsamp_lev
874 if(dl .ne. 2)
call mom_error(fatal,
"set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!")
875 do c=1, diag_cs%num_diag_coords
877 axes => diag_cs%remap_axesTL(c)
878 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
879 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
880 diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d
882 axes => diag_cs%remap_axesCuL(c)
883 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
884 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
885 diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d
887 axes => diag_cs%remap_axesCvL(c)
888 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
889 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
890 diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d
892 axes => diag_cs%remap_axesBL(c)
893 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
894 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
895 diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d
897 axes => diag_cs%remap_axesTi(c)
898 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,g%isc, g%jsc, &
899 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
900 diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d
902 axes => diag_cs%remap_axesCui(c)
903 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
904 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
905 diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d
907 axes => diag_cs%remap_axesCvi(c)
908 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,g%isc ,g%JscB, &
909 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
910 diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d
912 axes => diag_cs%remap_axesBi(c)
913 call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,g%IscB,g%JscB, &
914 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
915 diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d
918 end subroutine set_masks_for_axes_dsamp
921 subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q)
923 integer,
optional,
intent(in) :: id_area_t
924 integer,
optional,
intent(in) :: id_area_q
927 if (
present(id_area_t))
then
928 fms_id = diag_cs%diags(id_area_t)%fms_diag_id
929 diag_cs%axesT1%id_area = fms_id
930 diag_cs%axesTi%id_area = fms_id
931 diag_cs%axesTL%id_area = fms_id
932 do i=1, diag_cs%num_diag_coords
933 diag_cs%remap_axesTL(i)%id_area = fms_id
934 diag_cs%remap_axesTi(i)%id_area = fms_id
937 if (
present(id_area_q))
then
938 fms_id = diag_cs%diags(id_area_q)%fms_diag_id
939 diag_cs%axesB1%id_area = fms_id
940 diag_cs%axesBi%id_area = fms_id
941 diag_cs%axesBL%id_area = fms_id
942 do i=1, diag_cs%num_diag_coords
943 diag_cs%remap_axesBL(i)%id_area = fms_id
944 diag_cs%remap_axesBi(i)%id_area = fms_id
947 end subroutine diag_register_area_ids
950 subroutine register_cell_measure(G, diag, Time)
952 type(
diag_ctrl),
target,
intent(inout) :: diag
953 type(time_type),
intent(in) :: time
956 id = register_diag_field(
'ocean_model',
'volcello', diag%axesTL, &
957 time,
'Ocean grid-cell volume',
'm3', &
958 standard_name=
'ocean_volume', v_extensive=.true., &
959 x_cell_method=
'sum', y_cell_method=
'sum')
960 call diag_associate_volume_cell_measure(diag, id)
962 end subroutine register_cell_measure
965 subroutine diag_associate_volume_cell_measure(diag_cs, id_h_volume)
967 integer,
intent(in) :: id_h_volume
969 type(
diag_type),
pointer :: tmp => null()
971 if (id_h_volume<=0)
return
972 diag_cs%volume_cell_measure_dm_id = id_h_volume
975 diag_cs%diags(id_h_volume)%axes%id_volume = diag_cs%diags(id_h_volume)%fms_diag_id
977 tmp => diag_cs%diags(id_h_volume)%next
978 do while (
associated(tmp))
980 tmp%axes%id_volume = tmp%fms_diag_id
984 end subroutine diag_associate_volume_cell_measure
987 integer function diag_get_volume_cell_measure_dm_id(diag_cs)
990 diag_get_volume_cell_measure_dm_id = diag_cs%volume_cell_measure_dm_id
992 end function diag_get_volume_cell_measure_dm_id
995 subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, &
996 x_cell_method, y_cell_method, v_cell_method, &
997 is_h_point, is_q_point, is_u_point, is_v_point, &
998 is_layer, is_interface, &
999 is_native, needs_remapping, needs_interpolating, &
1002 integer,
dimension(:),
intent(in) :: handles
1003 type(
axes_grp),
intent(out) :: axes
1004 integer,
optional,
intent(in) :: nz
1005 integer,
optional,
intent(in) :: vertical_coordinate_number
1006 character(len=*),
optional,
intent(in) :: x_cell_method
1008 character(len=*),
optional,
intent(in) :: y_cell_method
1010 character(len=*),
optional,
intent(in) :: v_cell_method
1012 logical,
optional,
intent(in) :: is_h_point
1014 logical,
optional,
intent(in) :: is_q_point
1016 logical,
optional,
intent(in) :: is_u_point
1018 logical,
optional,
intent(in) :: is_v_point
1020 logical,
optional,
intent(in) :: is_layer
1022 logical,
optional,
intent(in) :: is_interface
1024 logical,
optional,
intent(in) :: is_native
1026 logical,
optional,
intent(in) :: needs_remapping
1029 logical,
optional,
intent(in) :: needs_interpolating
1032 type(
axes_grp),
optional,
target :: xyave_axes
1038 if (n<1 .or. n>3)
call mom_error(fatal,
"define_axes_group: wrong size for list of handles!")
1039 allocate( axes%handles(n) )
1040 axes%id = i2s(handles, n)
1042 axes%handles(:) = handles(:)
1043 axes%diag_cs => diag_cs
1044 if (
present(x_cell_method))
then
1045 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1046 'Can not set x_cell_method for rank<2.')
1047 axes%x_cell_method = trim(x_cell_method)
1049 axes%x_cell_method =
''
1051 if (
present(y_cell_method))
then
1052 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1053 'Can not set y_cell_method for rank<2.')
1054 axes%y_cell_method = trim(y_cell_method)
1056 axes%y_cell_method =
''
1058 if (
present(v_cell_method))
then
1059 if (axes%rank/=1 .and. axes%rank/=3)
call mom_error(fatal,
'define_axes_group: ' // &
1060 'Can not set v_cell_method for rank<>1 or 3.')
1061 axes%v_cell_method = trim(v_cell_method)
1063 axes%v_cell_method =
''
1065 if (
present(nz)) axes%nz = nz
1066 if (
present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1067 if (
present(is_h_point)) axes%is_h_point = is_h_point
1068 if (
present(is_q_point)) axes%is_q_point = is_q_point
1069 if (
present(is_u_point)) axes%is_u_point = is_u_point
1070 if (
present(is_v_point)) axes%is_v_point = is_v_point
1071 if (
present(is_layer)) axes%is_layer = is_layer
1072 if (
present(is_interface)) axes%is_interface = is_interface
1073 if (
present(is_native)) axes%is_native = is_native
1074 if (
present(needs_remapping)) axes%needs_remapping = needs_remapping
1075 if (
present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1076 if (
present(xyave_axes)) axes%xyave_axes => xyave_axes
1079 axes%mask2d => null()
1080 if (axes%rank==2)
then
1081 if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1082 if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1083 if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1084 if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1087 axes%mask3d => null()
1088 if (axes%rank==3 .and. axes%is_native)
then
1090 if (axes%is_layer)
then
1091 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1092 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1093 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1094 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1095 elseif (axes%is_interface)
then
1096 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1097 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1098 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1099 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1103 end subroutine define_axes_group
1106 subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coordinate_number, &
1107 x_cell_method, y_cell_method, v_cell_method, &
1108 is_h_point, is_q_point, is_u_point, is_v_point, &
1109 is_layer, is_interface, &
1110 is_native, needs_remapping, needs_interpolating, &
1113 integer,
dimension(:),
intent(in) :: handles
1114 type(
axes_grp),
intent(out) :: axes
1115 integer,
intent(in) :: dl
1116 integer,
optional,
intent(in) :: nz
1117 integer,
optional,
intent(in) :: vertical_coordinate_number
1118 character(len=*),
optional,
intent(in) :: x_cell_method
1120 character(len=*),
optional,
intent(in) :: y_cell_method
1122 character(len=*),
optional,
intent(in) :: v_cell_method
1124 logical,
optional,
intent(in) :: is_h_point
1126 logical,
optional,
intent(in) :: is_q_point
1128 logical,
optional,
intent(in) :: is_u_point
1130 logical,
optional,
intent(in) :: is_v_point
1132 logical,
optional,
intent(in) :: is_layer
1134 logical,
optional,
intent(in) :: is_interface
1136 logical,
optional,
intent(in) :: is_native
1138 logical,
optional,
intent(in) :: needs_remapping
1141 logical,
optional,
intent(in) :: needs_interpolating
1144 type(
axes_grp),
optional,
target :: xyave_axes
1150 if (n<1 .or. n>3)
call mom_error(fatal,
"define_axes_group: wrong size for list of handles!")
1151 allocate( axes%handles(n) )
1152 axes%id = i2s(handles, n)
1154 axes%handles(:) = handles(:)
1155 axes%diag_cs => diag_cs
1156 if (
present(x_cell_method))
then
1157 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1158 'Can not set x_cell_method for rank<2.')
1159 axes%x_cell_method = trim(x_cell_method)
1161 axes%x_cell_method =
''
1163 if (
present(y_cell_method))
then
1164 if (axes%rank<2)
call mom_error(fatal,
'define_axes_group: ' // &
1165 'Can not set y_cell_method for rank<2.')
1166 axes%y_cell_method = trim(y_cell_method)
1168 axes%y_cell_method =
''
1170 if (
present(v_cell_method))
then
1171 if (axes%rank/=1 .and. axes%rank/=3)
call mom_error(fatal,
'define_axes_group: ' // &
1172 'Can not set v_cell_method for rank<>1 or 3.')
1173 axes%v_cell_method = trim(v_cell_method)
1175 axes%v_cell_method =
''
1177 axes%downsample_level = dl
1178 if (
present(nz)) axes%nz = nz
1179 if (
present(vertical_coordinate_number)) axes%vertical_coordinate_number = vertical_coordinate_number
1180 if (
present(is_h_point)) axes%is_h_point = is_h_point
1181 if (
present(is_q_point)) axes%is_q_point = is_q_point
1182 if (
present(is_u_point)) axes%is_u_point = is_u_point
1183 if (
present(is_v_point)) axes%is_v_point = is_v_point
1184 if (
present(is_layer)) axes%is_layer = is_layer
1185 if (
present(is_interface)) axes%is_interface = is_interface
1186 if (
present(is_native)) axes%is_native = is_native
1187 if (
present(needs_remapping)) axes%needs_remapping = needs_remapping
1188 if (
present(needs_interpolating)) axes%needs_interpolating = needs_interpolating
1189 if (
present(xyave_axes)) axes%xyave_axes => xyave_axes
1193 axes%mask2d => null()
1194 if (axes%rank==2)
then
1195 if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT
1196 if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu
1197 if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv
1198 if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu
1201 axes%mask3d => null()
1202 if (axes%rank==3 .and. axes%is_native)
then
1204 if (axes%is_layer)
then
1205 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTL
1206 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCuL
1207 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvL
1208 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBL
1209 elseif (axes%is_interface)
then
1210 if (axes%is_h_point) axes%mask3d => diag_cs%mask3dTi
1211 if (axes%is_u_point) axes%mask3d => diag_cs%mask3dCui
1212 if (axes%is_v_point) axes%mask3d => diag_cs%mask3dCvi
1213 if (axes%is_q_point) axes%mask3d => diag_cs%mask3dBi
1217 axes%dsamp(dl)%mask2d => null()
1218 if (axes%rank==2)
then
1219 if (axes%is_h_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dT
1220 if (axes%is_u_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCu
1221 if (axes%is_v_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dCv
1222 if (axes%is_q_point) axes%dsamp(dl)%mask2d => diag_cs%dsamp(dl)%mask2dBu
1225 axes%dsamp(dl)%mask3d => null()
1226 if (axes%rank==3 .and. axes%is_native)
then
1228 if (axes%is_layer)
then
1229 if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTL
1230 if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCuL
1231 if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvL
1232 if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBL
1233 elseif (axes%is_interface)
then
1234 if (axes%is_h_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dTi
1235 if (axes%is_u_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCui
1236 if (axes%is_v_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dCvi
1237 if (axes%is_q_point) axes%dsamp(dl)%mask3d => diag_cs%dsamp(dl)%mask3dBi
1241 end subroutine define_axes_group_dsamp
1244 subroutine set_diag_mediator_grid(G, diag_cs)
1246 type(
diag_ctrl),
intent(inout) :: diag_cs
1248 diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
1249 diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
1250 diag_cs%isd = g%isd ; diag_cs%ied = g%ied
1251 diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
1253 end subroutine set_diag_mediator_grid
1256 subroutine post_data_0d(diag_field_id, field, diag_cs, is_static)
1257 integer,
intent(in) :: diag_field_id
1259 real,
intent(in) :: field
1260 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1261 logical,
optional,
intent(in) :: is_static
1265 logical :: used, is_stat
1266 type(
diag_type),
pointer :: diag => null()
1268 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1269 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1273 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1274 'post_data_0d: Unregistered diagnostic id')
1275 diag => diag_cs%diags(diag_field_id)
1277 do while (
associated(diag))
1279 if (diag%conversion_factor /= 0.) &
1280 locfield = locfield * diag%conversion_factor
1282 if (diag_cs%diag_as_chksum)
then
1283 call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit)
1284 else if (is_stat)
then
1285 used = send_data(diag%fms_diag_id, locfield)
1286 elseif (diag_cs%ave_enabled)
then
1287 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end)
1292 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1293 end subroutine post_data_0d
1296 subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static)
1297 integer,
intent(in) :: diag_field_id
1299 real,
target,
intent(in) :: field(:)
1300 type(
diag_ctrl),
target,
intent(in) :: diag_cs
1301 logical,
optional,
intent(in) :: is_static
1305 real,
dimension(:),
pointer :: locfield => null()
1307 integer :: k, ks, ke
1308 type(
diag_type),
pointer :: diag => null()
1310 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1311 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1314 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1315 'post_data_1d_k: Unregistered diagnostic id')
1316 diag => diag_cs%diags(diag_field_id)
1317 do while (
associated(diag))
1319 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1320 ks = lbound(field,1) ; ke = ubound(field,1)
1321 allocate( locfield( ks:ke ) )
1324 if (field(k) == diag_cs%missing_value)
then
1325 locfield(k) = diag_cs%missing_value
1327 locfield(k) = field(k) * diag%conversion_factor
1334 if (diag_cs%diag_as_chksum)
then
1335 call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit)
1336 else if (is_stat)
then
1337 used = send_data(diag%fms_diag_id, locfield)
1338 elseif (diag_cs%ave_enabled)
then
1339 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, weight=diag_cs%time_int)
1341 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1346 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1347 end subroutine post_data_1d_k
1350 subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask)
1351 integer,
intent(in) :: diag_field_id
1353 real,
intent(in) :: field(:,:)
1354 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1355 logical,
optional,
intent(in) :: is_static
1356 real,
optional,
intent(in) :: mask(:,:)
1359 type(
diag_type),
pointer :: diag => null()
1361 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1364 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1365 'post_data_2d: Unregistered diagnostic id')
1366 diag => diag_cs%diags(diag_field_id)
1367 do while (
associated(diag))
1368 call post_data_2d_low(diag, field, diag_cs, is_static, mask)
1372 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1373 end subroutine post_data_2d
1377 subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask)
1379 real,
target,
intent(in) :: field(:,:)
1381 logical,
optional,
intent(in) :: is_static
1382 real,
optional,
target,
intent(in) :: mask(:,:)
1385 real,
dimension(:,:),
pointer :: locfield
1386 real,
dimension(:,:),
pointer :: locmask
1387 character(len=300) :: mesg
1388 logical :: used, is_stat
1389 integer :: cszi, cszj, dszi, dszj
1390 integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o
1391 real,
dimension(:,:),
allocatable,
target :: locfield_dsamp
1392 real,
dimension(:,:),
allocatable,
target :: locmask_dsamp
1397 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1404 isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1406 cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1
1407 cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1
1408 if (
size(field,1) == dszi )
then
1409 isv = diag_cs%is ; iev = diag_cs%ie
1410 elseif (
size(field,1) == dszi + 1 )
then
1411 isv = diag_cs%is ; iev = diag_cs%ie+1
1412 elseif (
size(field,1) == cszi)
then
1413 isv = 1 ; iev = cszi
1414 elseif (
size(field,1) == cszi + 1 )
then
1415 isv = 1 ; iev = cszi+1
1417 write (mesg,*)
" peculiar size ",
size(field,1),
" in i-direction\n"//&
1418 "does not match one of ", cszi, cszi+1, dszi, dszi+1
1419 call mom_error(fatal,
"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1422 if (
size(field,2) == dszj )
then
1423 jsv = diag_cs%js ; jev = diag_cs%je
1424 elseif (
size(field,2) == dszj + 1 )
then
1425 jsv = diag_cs%js ; jev = diag_cs%je+1
1426 elseif (
size(field,2) == cszj )
then
1427 jsv = 1 ; jev = cszj
1428 elseif (
size(field,2) == cszj+1 )
then
1429 jsv = 1 ; jev = cszj+1
1431 write (mesg,*)
" peculiar size ",
size(field,2),
" in j-direction\n"//&
1432 "does not match one of ", cszj, cszj+1, dszj, dszj+1
1433 call mom_error(fatal,
"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg))
1436 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1437 allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) )
1438 do j=jsv,jev ;
do i=isv,iev
1439 if (field(i,j) == diag_cs%missing_value)
then
1440 locfield(i,j) = diag_cs%missing_value
1442 locfield(i,j) = field(i,j) * diag%conversion_factor
1445 locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor
1450 if (
present(mask))
then
1452 elseif(.NOT. is_stat)
then
1453 if(
associated(diag%axes%mask2d)) locmask => diag%axes%mask2d
1457 if(.NOT. is_stat) dl = diag%axes%downsample_level
1460 isv_o=isv ; jsv_o=jsv
1462 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1463 locfield => locfield_dsamp
1464 if (
present(mask))
then
1465 call downsample_field_2d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1466 locmask => locmask_dsamp
1467 elseif(
associated(diag%axes%dsamp(dl)%mask2d))
then
1468 locmask => diag%axes%dsamp(dl)%mask2d
1472 if (diag_cs%diag_as_chksum)
then
1473 if (diag%axes%is_h_point)
then
1474 call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1475 logunit=diag_cs%chksum_iounit)
1476 else if (diag%axes%is_u_point)
then
1477 call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1478 logunit=diag_cs%chksum_iounit)
1479 else if (diag%axes%is_v_point)
then
1480 call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1481 logunit=diag_cs%chksum_iounit)
1482 else if (diag%axes%is_q_point)
then
1483 call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1484 logunit=diag_cs%chksum_iounit)
1486 call mom_error(fatal,
"post_data_2d_low: unknown axis type.")
1490 if (
present(mask))
then
1491 call assert(
size(locfield) ==
size(locmask), &
1492 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str)
1493 used = send_data(diag%fms_diag_id, locfield, &
1494 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1499 used = send_data(diag%fms_diag_id, locfield, &
1500 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1502 elseif (diag_cs%ave_enabled)
then
1503 if (
associated(locmask))
then
1504 call assert(
size(locfield) ==
size(locmask), &
1505 'post_data_2d_low: mask size mismatch: '//diag%debug_str)
1506 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1507 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1508 weight=diag_cs%time_int, rmask=locmask)
1510 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1511 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1512 weight=diag_cs%time_int)
1516 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1517 deallocate( locfield )
1518 end subroutine post_data_2d_low
1521 subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h)
1523 integer,
intent(in) :: diag_field_id
1525 real,
intent(in) :: field(:,:,:)
1526 type(
diag_ctrl),
target,
intent(in) :: diag_CS
1527 logical,
optional,
intent(in) :: is_static
1528 real,
optional,
intent(in) :: mask(:,:,:)
1529 real,
dimension(:,:,:), &
1530 target,
optional,
intent(in) :: alt_h
1534 type(
diag_type),
pointer :: diag => null()
1535 integer :: nz, i, j, k
1536 real,
dimension(:,:,:),
allocatable :: remapped_field
1537 logical :: staggered_in_x, staggered_in_y
1538 real,
dimension(:,:,:),
pointer :: h_diag => null()
1540 if (id_clock_diag_mediator>0)
call cpu_clock_begin(id_clock_diag_mediator)
1544 if (
present(alt_h))
then
1552 call assert(diag_field_id < diag_cs%next_free_diag_id, &
1553 'post_data_3d: Unregistered diagnostic id')
1554 diag => diag_cs%diags(diag_field_id)
1555 do while (
associated(diag))
1556 call assert(
associated(diag%axes),
'post_data_3d: axes is not associated')
1558 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1559 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1561 if (diag%v_extensive .and. .not.diag%axes%is_native)
then
1563 if (
present(mask))
then
1564 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1567 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1568 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz))
1569 call vertically_reintegrate_diag_field( &
1570 diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, &
1572 diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, &
1573 staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field)
1574 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1575 if (
associated(diag%axes%mask3d))
then
1578 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1579 mask=diag%axes%mask3d)
1581 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1583 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1584 deallocate(remapped_field)
1585 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1586 elseif (diag%axes%needs_remapping)
then
1588 if (
present(mask))
then
1589 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1592 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1593 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz))
1594 call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), &
1595 diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, &
1596 diag%axes%mask3d, field, remapped_field)
1597 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1598 if (
associated(diag%axes%mask3d))
then
1601 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1602 mask=diag%axes%mask3d)
1604 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1606 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1607 deallocate(remapped_field)
1608 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1609 elseif (diag%axes%needs_interpolating)
then
1611 if (
present(mask))
then
1612 call mom_error(fatal,
"post_data_3d: no mask for regridded field.")
1615 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1616 allocate(remapped_field(
size(field,1),
size(field,2), diag%axes%nz+1))
1617 call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( &
1618 diag%axes%vertical_coordinate_number), &
1619 diag_cs%G, h_diag, staggered_in_x, staggered_in_y, &
1620 diag%axes%mask3d, field, remapped_field)
1621 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1622 if (
associated(diag%axes%mask3d))
then
1625 call post_data_3d_low(diag, remapped_field, diag_cs, is_static, &
1626 mask=diag%axes%mask3d)
1628 call post_data_3d_low(diag, remapped_field, diag_cs, is_static)
1630 if (id_clock_diag_remap>0)
call cpu_clock_begin(id_clock_diag_remap)
1631 deallocate(remapped_field)
1632 if (id_clock_diag_remap>0)
call cpu_clock_end(id_clock_diag_remap)
1634 call post_data_3d_low(diag, field, diag_cs, is_static, mask)
1638 if (id_clock_diag_mediator>0)
call cpu_clock_end(id_clock_diag_mediator)
1640 end subroutine post_data_3d
1644 subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask)
1646 real,
target,
intent(in) :: field(:,:,:)
1648 logical,
optional,
intent(in) :: is_static
1649 real,
optional,
target,
intent(in) :: mask(:,:,:)
1652 real,
dimension(:,:,:),
pointer :: locfield
1653 real,
dimension(:,:,:),
pointer :: locmask
1654 character(len=300) :: mesg
1656 logical :: staggered_in_x, staggered_in_y
1658 integer :: cszi, cszj, dszi, dszj
1659 integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o
1661 real,
dimension(:,:,:),
allocatable,
target :: locfield_dsamp
1662 real,
dimension(:,:,:),
allocatable,
target :: locmask_dsamp
1667 is_stat = .false. ;
if (
present(is_static)) is_stat = is_static
1674 isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je
1676 cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1
1677 cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1
1678 if (
size(field,1) == dszi )
then
1679 isv = diag_cs%is ; iev = diag_cs%ie
1680 elseif (
size(field,1) == dszi + 1 )
then
1681 isv = diag_cs%is ; iev = diag_cs%ie+1
1682 elseif (
size(field,1) == cszi)
then
1683 isv = 1 ; iev = cszi
1684 elseif (
size(field,1) == cszi + 1 )
then
1685 isv = 1 ; iev = cszi+1
1687 write (mesg,*)
" peculiar size ",
size(field,1),
" in i-direction\n"//&
1688 "does not match one of ", cszi, cszi+1, dszi, dszi+1
1689 call mom_error(fatal,
"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1692 if (
size(field,2) == dszj )
then
1693 jsv = diag_cs%js ; jev = diag_cs%je
1694 elseif (
size(field,2) == dszj + 1 )
then
1695 jsv = diag_cs%js ; jev = diag_cs%je+1
1696 elseif (
size(field,2) == cszj )
then
1697 jsv = 1 ; jev = cszj
1698 elseif (
size(field,2) == cszj+1 )
then
1699 jsv = 1 ; jev = cszj+1
1701 write (mesg,*)
" peculiar size ",
size(field,2),
" in j-direction\n"//&
1702 "does not match one of ", cszj, cszj+1, dszj, dszj+1
1703 call mom_error(fatal,
"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg))
1706 ks = lbound(field,3) ; ke = ubound(field,3)
1707 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
then
1708 allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) )
1711 isv_c = isv ; jsv_c = jsv
1712 if (diag%fms_xyave_diag_id>0)
then
1713 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1714 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1716 if (staggered_in_x) isv_c = iev - (diag_cs%ie - diag_cs%is) - 1
1717 if (staggered_in_y) jsv_c = jev - (diag_cs%je - diag_cs%js) - 1
1718 if (isv_c < lbound(locfield,1))
call mom_error(fatal, &
1719 "It is an error to average a staggered diagnostic field that does not "//&
1720 "have i-direction space to represent the symmetric computational domain.")
1721 if (jsv_c < lbound(locfield,2))
call mom_error(fatal, &
1722 "It is an error to average a staggered diagnostic field that does not "//&
1723 "have j-direction space to represent the symmetric computational domain.")
1726 do k=ks,ke ;
do j=jsv,jev ;
do i=isv,iev
1727 if (field(i,j,k) == diag_cs%missing_value)
then
1728 locfield(i,j,k) = diag_cs%missing_value
1730 locfield(i,j,k) = field(i,j,k) * diag%conversion_factor
1732 enddo ;
enddo ;
enddo
1737 if (
present(mask))
then
1739 elseif(
associated(diag%axes%mask3d))
then
1740 locmask => diag%axes%mask3d
1744 if(.NOT. is_stat) dl = diag%axes%downsample_level
1747 isv_o=isv ; jsv_o=jsv
1749 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.))
deallocate( locfield )
1750 locfield => locfield_dsamp
1751 if (
present(mask))
then
1752 call downsample_field_3d(locmask, locmask_dsamp, dl, msk, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev)
1753 locmask => locmask_dsamp
1754 elseif(
associated(diag%axes%dsamp(dl)%mask3d))
then
1755 locmask => diag%axes%dsamp(dl)%mask3d
1759 if (diag%fms_diag_id>0)
then
1760 if (diag_cs%diag_as_chksum)
then
1761 if (diag%axes%is_h_point)
then
1762 call hchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1763 logunit=diag_cs%chksum_iounit)
1764 else if (diag%axes%is_u_point)
then
1765 call uchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1766 logunit=diag_cs%chksum_iounit)
1767 else if (diag%axes%is_v_point)
then
1768 call vchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1769 logunit=diag_cs%chksum_iounit)
1770 else if (diag%axes%is_q_point)
then
1771 call bchksum(locfield, diag%debug_str, diag_cs%G%HI, &
1772 logunit=diag_cs%chksum_iounit)
1774 call mom_error(fatal,
"post_data_3d_low: unknown axis type.")
1778 if (
present(mask))
then
1779 call assert(
size(locfield) ==
size(locmask), &
1780 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str)
1781 used = send_data(diag%fms_diag_id, locfield, &
1782 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=locmask)
1787 used = send_data(diag%fms_diag_id, locfield, &
1788 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev)
1790 elseif (diag_cs%ave_enabled)
then
1791 if (
associated(locmask))
then
1792 call assert(
size(locfield) ==
size(locmask), &
1793 'post_data_3d_low: mask size mismatch: '//diag%debug_str)
1794 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1795 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1796 weight=diag_cs%time_int, rmask=locmask)
1798 used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, &
1799 is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, &
1800 weight=diag_cs%time_int)
1806 if (diag%fms_xyave_diag_id>0)
then
1807 call post_xy_average(diag_cs, diag, locfield)
1810 if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) .and. dl<2) &
1811 deallocate( locfield )
1813 end subroutine post_data_3d_low
1816 subroutine post_xy_average(diag_cs, diag, field)
1818 real,
target,
intent(in) :: field(:,:,:)
1821 real,
dimension(size(field,3)) :: averaged_field
1822 logical,
dimension(size(field,3)) :: averaged_mask
1823 logical :: staggered_in_x, staggered_in_y, used
1824 integer :: nz, remap_nz, coord
1826 if (.not. diag_cs%ave_enabled)
then
1830 staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point
1831 staggered_in_y = diag%axes%is_v_point .or. diag%axes%is_q_point
1833 if (diag%axes%is_native)
then
1834 call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, &
1835 staggered_in_x, staggered_in_y, &
1836 diag%axes%is_layer, diag%v_extensive, &
1838 averaged_field, averaged_mask)
1841 coord = diag%axes%vertical_coordinate_number
1842 remap_nz = diag_cs%diag_remap_cs(coord)%nz
1844 call assert(diag_cs%diag_remap_cs(coord)%initialized, &
1845 'post_xy_average: remap_cs not initialized.')
1847 call assert(implies(diag%axes%is_layer, nz == remap_nz), &
1848 'post_xy_average: layer field dimension mismatch.')
1849 call assert(implies(.not. diag%axes%is_layer, nz == remap_nz+1), &
1850 'post_xy_average: interface field dimension mismatch.')
1852 call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, &
1853 diag_cs%diag_remap_cs(coord)%h, &
1854 staggered_in_x, staggered_in_y, &
1855 diag%axes%is_layer, diag%v_extensive, &
1857 averaged_field, averaged_mask)
1860 if (diag_cs%diag_as_chksum)
then
1861 call zchksum(averaged_field, trim(diag%debug_str)//
'_xyave', &
1862 logunit=diag_cs%chksum_iounit)
1864 used = send_data(diag%fms_xyave_diag_id, averaged_field, diag_cs%time_end, &
1865 weight=diag_cs%time_int, mask=averaged_mask)
1867 end subroutine post_xy_average
1870 subroutine enable_averaging(time_int_in, time_end_in, diag_cs)
1871 real,
intent(in) :: time_int_in
1873 type(time_type),
intent(in) :: time_end_in
1874 type(
diag_ctrl),
intent(inout) :: diag_cs
1879 diag_cs%time_int = time_int_in
1880 diag_cs%time_end = time_end_in
1881 diag_cs%ave_enabled = .true.
1882 end subroutine enable_averaging
1885 subroutine enable_averages(time_int, time_end, diag_CS, T_to_s)
1886 real,
intent(in) :: time_int
1888 type(time_type),
intent(in) :: time_end
1889 type(
diag_ctrl),
intent(inout) :: diag_cs
1890 real,
optional,
intent(in) :: t_to_s
1893 if (
present(t_to_s))
then
1894 diag_cs%time_int = time_int*t_to_s
1895 elseif (
associated(diag_cs%US))
then
1896 diag_cs%time_int = time_int*diag_cs%US%T_to_s
1898 diag_cs%time_int = time_int
1900 diag_cs%time_end = time_end
1901 diag_cs%ave_enabled = .true.
1902 end subroutine enable_averages
1905 subroutine disable_averaging(diag_cs)
1908 diag_cs%time_int = 0.0
1909 diag_cs%ave_enabled = .false.
1911 end subroutine disable_averaging
1915 function query_averaging_enabled(diag_cs, time_int, time_end)
1917 real,
optional,
intent(out) :: time_int
1918 type(time_type),
optional,
intent(out) :: time_end
1919 logical :: query_averaging_enabled
1921 if (
present(time_int)) time_int = diag_cs%time_int
1922 if (
present(time_end)) time_end = diag_cs%time_end
1923 query_averaging_enabled = diag_cs%ave_enabled
1924 end function query_averaging_enabled
1928 function get_diag_time_end(diag_cs)
1930 type(time_type) :: get_diag_time_end
1934 get_diag_time_end = diag_cs%time_end
1935 end function get_diag_time_end
1939 integer function register_diag_field(module_name, field_name, axes_in, init_time, &
1940 long_name, units, missing_value, range, mask_variant, standard_name, &
1941 verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
1942 cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
1943 x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
1944 character(len=*),
intent(in) :: module_name
1946 character(len=*),
intent(in) :: field_name
1947 type(
axes_grp),
target,
intent(in) :: axes_in
1949 type(time_type),
intent(in) :: init_time
1950 character(len=*),
optional,
intent(in) :: long_name
1951 character(len=*),
optional,
intent(in) :: units
1952 character(len=*),
optional,
intent(in) :: standard_name
1953 real,
optional,
intent(in) :: missing_value
1954 real,
optional,
intent(in) :: range(2)
1955 logical,
optional,
intent(in) :: mask_variant
1957 logical,
optional,
intent(in) :: verbose
1958 logical,
optional,
intent(in) :: do_not_log
1959 character(len=*),
optional,
intent(out):: err_msg
1961 character(len=*),
optional,
intent(in) :: interp_method
1963 integer,
optional,
intent(in) :: tile_count
1964 character(len=*),
optional,
intent(in) :: cmor_field_name
1965 character(len=*),
optional,
intent(in) :: cmor_long_name
1966 character(len=*),
optional,
intent(in) :: cmor_units
1967 character(len=*),
optional,
intent(in) :: cmor_standard_name
1968 character(len=*),
optional,
intent(in) :: cell_methods
1972 character(len=*),
optional,
intent(in) :: x_cell_method
1974 character(len=*),
optional,
intent(in) :: y_cell_method
1976 character(len=*),
optional,
intent(in) :: v_cell_method
1978 real,
optional,
intent(in) :: conversion
1979 logical,
optional,
intent(in) :: v_extensive
1982 real :: mom_missing_value
1983 type(
diag_ctrl),
pointer :: diag_cs => null()
1984 type(
axes_grp),
pointer :: remap_axes => null()
1985 type(
axes_grp),
pointer :: axes => null()
1986 integer :: dm_id, i, dl
1987 character(len=256) :: new_module_name
1991 mom_missing_value = axes%diag_cs%missing_value
1992 if (
present(missing_value)) mom_missing_value = missing_value
1994 diag_cs => axes%diag_cs
1997 if (axes_in%id == diag_cs%axesTL%id)
then
1998 axes => diag_cs%axesTL
1999 elseif (axes_in%id == diag_cs%axesBL%id)
then
2000 axes => diag_cs%axesBL
2001 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2002 axes => diag_cs%axesCuL
2003 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2004 axes => diag_cs%axesCvL
2005 elseif (axes_in%id == diag_cs%axesTi%id)
then
2006 axes => diag_cs%axesTi
2007 elseif (axes_in%id == diag_cs%axesBi%id)
then
2008 axes => diag_cs%axesBi
2009 elseif (axes_in%id == diag_cs%axesCui%id )
then
2010 axes => diag_cs%axesCui
2011 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2012 axes => diag_cs%axesCvi
2016 active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, &
2017 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2018 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2019 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2020 interp_method=interp_method, tile_count=tile_count, &
2021 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2022 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2023 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2024 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2025 conversion=conversion, v_extensive=v_extensive)
2028 do i=1,diag_cs%num_diag_coords
2029 new_module_name = trim(module_name)//
'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)
2032 if (axes_in%rank == 3)
then
2033 remap_axes => null()
2034 if ((axes_in%id == diag_cs%axesTL%id))
then
2035 remap_axes => diag_cs%remap_axesTL(i)
2036 elseif (axes_in%id == diag_cs%axesBL%id)
then
2037 remap_axes => diag_cs%remap_axesBL(i)
2038 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2039 remap_axes => diag_cs%remap_axesCuL(i)
2040 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2041 remap_axes => diag_cs%remap_axesCvL(i)
2042 elseif (axes_in%id == diag_cs%axesTi%id)
then
2043 remap_axes => diag_cs%remap_axesTi(i)
2044 elseif (axes_in%id == diag_cs%axesBi%id)
then
2045 remap_axes => diag_cs%remap_axesBi(i)
2046 elseif (axes_in%id == diag_cs%axesCui%id )
then
2047 remap_axes => diag_cs%remap_axesCui(i)
2048 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2049 remap_axes => diag_cs%remap_axesCvi(i)
2054 if (
associated(remap_axes))
then
2055 if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating)
then
2056 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
2057 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2058 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2059 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2060 interp_method=interp_method, tile_count=tile_count, &
2061 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2062 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2063 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2064 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2065 conversion=conversion, v_extensive=v_extensive)
2067 call diag_remap_set_active(diag_cs%diag_remap_cs(i))
2075 do dl=2,max_dsamp_lev
2077 if (diag_cs%diag_as_chksum) cycle
2079 new_module_name = trim(module_name)//
'_d2'
2081 if (axes_in%rank == 3 .or. axes_in%rank == 2 )
then
2083 if (axes_in%id == diag_cs%axesTL%id)
then
2084 axes => diag_cs%dsamp(dl)%axesTL
2085 elseif (axes_in%id == diag_cs%axesBL%id)
then
2086 axes => diag_cs%dsamp(dl)%axesBL
2087 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2088 axes => diag_cs%dsamp(dl)%axesCuL
2089 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2090 axes => diag_cs%dsamp(dl)%axesCvL
2091 elseif (axes_in%id == diag_cs%axesTi%id)
then
2092 axes => diag_cs%dsamp(dl)%axesTi
2093 elseif (axes_in%id == diag_cs%axesBi%id)
then
2094 axes => diag_cs%dsamp(dl)%axesBi
2095 elseif (axes_in%id == diag_cs%axesCui%id )
then
2096 axes => diag_cs%dsamp(dl)%axesCui
2097 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2098 axes => diag_cs%dsamp(dl)%axesCvi
2099 elseif (axes_in%id == diag_cs%axesT1%id)
then
2100 axes => diag_cs%dsamp(dl)%axesT1
2101 elseif (axes_in%id == diag_cs%axesB1%id)
then
2102 axes => diag_cs%dsamp(dl)%axesB1
2103 elseif (axes_in%id == diag_cs%axesCu1%id )
then
2104 axes => diag_cs%dsamp(dl)%axesCu1
2105 elseif (axes_in%id == diag_cs%axesCv1%id)
then
2106 axes => diag_cs%dsamp(dl)%axesCv1
2109 call mom_error(warning,
"register_diag_field: Could not find a proper axes for " &
2110 //trim( new_module_name)//
"-"//trim(field_name))
2114 if (
associated(axes))
then
2115 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes, &
2116 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2117 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2118 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2119 interp_method=interp_method, tile_count=tile_count, &
2120 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2121 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2122 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2123 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2124 conversion=conversion, v_extensive=v_extensive)
2128 do i=1,diag_cs%num_diag_coords
2129 new_module_name = trim(module_name)//
'_'//trim(diag_cs%diag_remap_cs(i)%diag_module_suffix)//
'_d2'
2132 if (axes_in%rank == 3)
then
2133 remap_axes => null()
2134 if ((axes_in%id == diag_cs%axesTL%id))
then
2135 remap_axes => diag_cs%dsamp(dl)%remap_axesTL(i)
2136 elseif (axes_in%id == diag_cs%axesBL%id)
then
2137 remap_axes => diag_cs%dsamp(dl)%remap_axesBL(i)
2138 elseif (axes_in%id == diag_cs%axesCuL%id )
then
2139 remap_axes => diag_cs%dsamp(dl)%remap_axesCuL(i)
2140 elseif (axes_in%id == diag_cs%axesCvL%id)
then
2141 remap_axes => diag_cs%dsamp(dl)%remap_axesCvL(i)
2142 elseif (axes_in%id == diag_cs%axesTi%id)
then
2143 remap_axes => diag_cs%dsamp(dl)%remap_axesTi(i)
2144 elseif (axes_in%id == diag_cs%axesBi%id)
then
2145 remap_axes => diag_cs%dsamp(dl)%remap_axesBi(i)
2146 elseif (axes_in%id == diag_cs%axesCui%id )
then
2147 remap_axes => diag_cs%dsamp(dl)%remap_axesCui(i)
2148 elseif (axes_in%id == diag_cs%axesCvi%id)
then
2149 remap_axes => diag_cs%dsamp(dl)%remap_axesCvi(i)
2155 if (
associated(remap_axes))
then
2156 if (remap_axes%needs_remapping .or. remap_axes%needs_interpolating)
then
2157 active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, remap_axes, &
2158 init_time, long_name=long_name, units=units, missing_value=mom_missing_value, &
2159 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2160 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2161 interp_method=interp_method, tile_count=tile_count, &
2162 cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, &
2163 cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, &
2164 cell_methods=cell_methods, x_cell_method=x_cell_method, &
2165 y_cell_method=y_cell_method, v_cell_method=v_cell_method, &
2166 conversion=conversion, v_extensive=v_extensive)
2168 call diag_remap_set_active(diag_cs%diag_remap_cs(i))
2176 register_diag_field = dm_id
2178 end function register_diag_field
2182 logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, &
2183 long_name, units, missing_value, range, mask_variant, standard_name, &
2184 verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, &
2185 cmor_long_name, cmor_units, cmor_standard_name, cell_methods, &
2186 x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive)
2187 integer,
intent(inout) :: dm_id
2188 character(len=*),
intent(in) :: module_name
2189 character(len=*),
intent(in) :: field_name
2190 type(
axes_grp),
target,
intent(in) :: axes
2192 type(time_type),
intent(in) :: init_time
2193 character(len=*),
optional,
intent(in) :: long_name
2194 character(len=*),
optional,
intent(in) :: units
2195 character(len=*),
optional,
intent(in) :: standard_name
2196 real,
optional,
intent(in) :: missing_value
2197 real,
optional,
intent(in) :: range(2)
2198 logical,
optional,
intent(in) :: mask_variant
2200 logical,
optional,
intent(in) :: verbose
2201 logical,
optional,
intent(in) :: do_not_log
2202 character(len=*),
optional,
intent(out):: err_msg
2204 character(len=*),
optional,
intent(in) :: interp_method
2206 integer,
optional,
intent(in) :: tile_count
2207 character(len=*),
optional,
intent(in) :: cmor_field_name
2208 character(len=*),
optional,
intent(in) :: cmor_long_name
2209 character(len=*),
optional,
intent(in) :: cmor_units
2210 character(len=*),
optional,
intent(in) :: cmor_standard_name
2211 character(len=*),
optional,
intent(in) :: cell_methods
2215 character(len=*),
optional,
intent(in) :: x_cell_method
2217 character(len=*),
optional,
intent(in) :: y_cell_method
2219 character(len=*),
optional,
intent(in) :: v_cell_method
2221 real,
optional,
intent(in) :: conversion
2222 logical,
optional,
intent(in) :: v_extensive
2225 real :: mom_missing_value
2226 type(
diag_ctrl),
pointer :: diag_cs => null()
2227 type(
diag_type),
pointer :: this_diag => null()
2228 integer :: fms_id, fms_xyave_id
2229 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg
2231 mom_missing_value = axes%diag_cs%missing_value
2232 if (
present(missing_value)) mom_missing_value = missing_value
2234 register_diag_field_expand_cmor = .false.
2235 diag_cs => axes%diag_cs
2238 fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2239 long_name=long_name, units=units, missing_value=mom_missing_value, &
2240 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2241 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2242 interp_method=interp_method, tile_count=tile_count)
2243 if (.not. diag_cs%diag_as_chksum) &
2244 call attach_cell_methods(fms_id, axes, cm_string, cell_methods, &
2245 x_cell_method, y_cell_method, v_cell_method, &
2246 v_extensive=v_extensive)
2247 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2249 if (
present(cmor_field_name)) msg =
'CMOR equivalent is "'//trim(cmor_field_name)//
'"'
2250 call log_available_diag(fms_id>0, module_name, field_name, cm_string, &
2251 msg, diag_cs, long_name, units, standard_name)
2254 fms_xyave_id = diag_field_not_found
2255 if (
associated(axes%xyave_axes))
then
2256 fms_xyave_id = register_diag_field_expand_axes(module_name, trim(field_name)//
'_xyave', &
2257 axes%xyave_axes, init_time, &
2258 long_name=long_name, units=units, missing_value=mom_missing_value, &
2259 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2260 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2261 interp_method=interp_method, tile_count=tile_count)
2262 if (.not. diag_cs%diag_as_chksum) &
2263 call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2264 cell_methods, v_cell_method, v_extensive=v_extensive)
2265 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2267 if (
present(cmor_field_name)) msg =
'CMOR equivalent is "'//trim(cmor_field_name)//
'_xyave"'
2268 call log_available_diag(fms_xyave_id>0, module_name, trim(field_name)//
'_xyave', cm_string, &
2269 msg, diag_cs, long_name, units, standard_name)
2273 if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found)
then
2274 call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2275 this_diag%fms_xyave_diag_id = fms_xyave_id
2277 call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2278 if (
present(v_extensive)) this_diag%v_extensive = v_extensive
2279 if (
present(conversion)) this_diag%conversion_factor = conversion
2280 register_diag_field_expand_cmor = .true.
2284 if (
present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum)
then
2286 posted_cmor_units =
"not provided"
2287 posted_cmor_standard_name =
"not provided"
2288 posted_cmor_long_name =
"not provided"
2292 if (
present(units)) posted_cmor_units = units
2293 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2294 if (
present(long_name)) posted_cmor_long_name = long_name
2297 if (
present(cmor_units)) posted_cmor_units = cmor_units
2298 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2299 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2301 fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, &
2302 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2303 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2304 standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2305 err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2306 call attach_cell_methods(fms_id, axes, cm_string, &
2307 cell_methods, x_cell_method, y_cell_method, v_cell_method, &
2308 v_extensive=v_extensive)
2309 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2310 msg =
'native name is "'//trim(field_name)//
'"'
2311 call log_available_diag(fms_id>0, module_name, cmor_field_name, cm_string, &
2312 msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2313 posted_cmor_standard_name)
2316 fms_xyave_id = diag_field_not_found
2317 if (
associated(axes%xyave_axes))
then
2318 fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//
'_xyave', &
2319 axes%xyave_axes, init_time, &
2320 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2321 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2322 standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, &
2323 err_msg=err_msg, interp_method=interp_method, tile_count=tile_count)
2324 call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, &
2325 cell_methods, v_cell_method, v_extensive=v_extensive)
2326 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2327 msg =
'native name is "'//trim(field_name)//
'_xyave"'
2328 call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//
'_xyave', &
2329 cm_string, msg, diag_cs, posted_cmor_long_name, posted_cmor_units, &
2330 posted_cmor_standard_name)
2334 if (fms_id /= diag_field_not_found .or. fms_xyave_id /= diag_field_not_found)
then
2335 call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2336 this_diag%fms_xyave_diag_id = fms_xyave_id
2338 call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2339 if (
present(v_extensive)) this_diag%v_extensive = v_extensive
2340 if (
present(conversion)) this_diag%conversion_factor = conversion
2341 register_diag_field_expand_cmor = .true.
2345 end function register_diag_field_expand_cmor
2349 integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, &
2350 long_name, units, missing_value, range, mask_variant, standard_name, &
2351 verbose, do_not_log, err_msg, interp_method, tile_count)
2352 character(len=*),
intent(in) :: module_name
2354 character(len=*),
intent(in) :: field_name
2355 type(
axes_grp),
target,
intent(in) :: axes
2357 type(time_type),
intent(in) :: init_time
2358 character(len=*),
optional,
intent(in) :: long_name
2359 character(len=*),
optional,
intent(in) :: units
2360 character(len=*),
optional,
intent(in) :: standard_name
2361 real,
optional,
intent(in) :: missing_value
2362 real,
optional,
intent(in) :: range(2)
2363 logical,
optional,
intent(in) :: mask_variant
2365 logical,
optional,
intent(in) :: verbose
2366 logical,
optional,
intent(in) :: do_not_log
2368 character(len=*),
optional,
intent(out):: err_msg
2370 character(len=*),
optional,
intent(in) :: interp_method
2372 integer,
optional,
intent(in) :: tile_count
2374 integer :: fms_id, area_id, volume_id
2377 area_id = axes%id_area
2378 volume_id = axes%id_volume
2381 if (axes%diag_cs%diag_as_chksum)
then
2382 fms_id = axes%diag_cs%num_chksum_diags + 1
2383 axes%diag_cs%num_chksum_diags = fms_id
2384 else if (
present(interp_method) .or. axes%is_h_point)
then
2387 if (volume_id>0)
then
2389 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2390 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2391 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2392 interp_method=interp_method, tile_count=tile_count, area=area_id, volume=volume_id)
2395 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2396 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2397 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2398 interp_method=interp_method, tile_count=tile_count, area=area_id)
2401 if (volume_id>0)
then
2403 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2404 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2405 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2406 interp_method=interp_method, tile_count=tile_count, volume=volume_id)
2409 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2410 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2411 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2412 interp_method=interp_method, tile_count=tile_count)
2418 if (volume_id>0)
then
2420 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2421 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2422 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2423 interp_method=
'none', tile_count=tile_count, area=area_id, volume=volume_id)
2426 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2427 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2428 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2429 interp_method=
'none', tile_count=tile_count, area=area_id)
2432 if (volume_id>0)
then
2434 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2435 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2436 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2437 interp_method=
'none', tile_count=tile_count, volume=volume_id)
2440 init_time, long_name=long_name, units=units, missing_value=missing_value, &
2441 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2442 verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, &
2443 interp_method=
'none', tile_count=tile_count)
2448 register_diag_field_expand_axes = fms_id
2450 end function register_diag_field_expand_axes
2453 subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg)
2455 integer,
intent(inout) :: dm_id
2456 integer,
intent(in) :: fms_id
2458 type(
axes_grp),
target,
intent(in) :: axes
2460 character(len=*),
intent(in) :: module_name
2462 character(len=*),
intent(in) :: field_name
2463 character(len=*),
intent(in) :: msg
2466 if (dm_id == -1) dm_id = get_new_diag_id(diag_cs)
2468 call alloc_diag_with_id(dm_id, diag_cs, this_diag)
2469 call assert(
associated(this_diag), trim(msg)//
': diag_type allocation failed')
2471 this_diag%fms_diag_id = fms_id
2472 this_diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2473 this_diag%axes => axes
2475 end subroutine add_diag_to_list
2479 subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive)
2483 character(len=*),
optional,
intent(in) :: x_cell_method
2485 character(len=*),
optional,
intent(in) :: y_cell_method
2487 character(len=*),
optional,
intent(in) :: v_cell_method
2489 logical,
optional,
intent(in) :: v_extensive
2491 integer :: xyz_method
2492 character(len=9) :: mstr
2503 mstr = diag%axes%v_cell_method
2504 if (
present(v_extensive))
then
2505 if (
present(v_cell_method))
call mom_error(fatal,
"attach_cell_methods: " // &
2506 'Vertical cell method was specified along with the vertically extensive flag.')
2507 if(v_extensive)
then
2512 elseif (
present(v_cell_method))
then
2513 mstr = v_cell_method
2515 if (trim(mstr)==
'sum')
then
2516 xyz_method = xyz_method + 1
2517 elseif (trim(mstr)==
'mean')
then
2518 xyz_method = xyz_method + 2
2521 mstr = diag%axes%y_cell_method
2522 if (
present(y_cell_method)) mstr = y_cell_method
2523 if (trim(mstr)==
'sum')
then
2524 xyz_method = xyz_method + 10
2525 elseif (trim(mstr)==
'mean')
then
2526 xyz_method = xyz_method + 20
2529 mstr = diag%axes%x_cell_method
2530 if (
present(x_cell_method)) mstr = x_cell_method
2531 if (trim(mstr)==
'sum')
then
2532 xyz_method = xyz_method + 100
2533 elseif (trim(mstr)==
'mean')
then
2534 xyz_method = xyz_method + 200
2537 diag%xyz_method = xyz_method
2538 end subroutine add_xyz_method
2541 subroutine attach_cell_methods(id, axes, ostring, cell_methods, &
2542 x_cell_method, y_cell_method, v_cell_method, v_extensive)
2543 integer,
intent(in) :: id
2546 character(len=*),
intent(out) :: ostring
2547 character(len=*),
optional,
intent(in) :: cell_methods
2551 character(len=*),
optional,
intent(in) :: x_cell_method
2553 character(len=*),
optional,
intent(in) :: y_cell_method
2555 character(len=*),
optional,
intent(in) :: v_cell_method
2557 logical,
optional,
intent(in) :: v_extensive
2560 character(len=9) :: axis_name
2561 logical :: x_mean, y_mean, x_sum, y_sum
2569 if (
present(cell_methods))
then
2570 if (
present(x_cell_method) .or.
present(y_cell_method) .or.
present(v_cell_method) &
2571 .or.
present(v_extensive))
then
2572 call mom_error(fatal,
"attach_cell_methods: " // &
2573 'Individual direction cell method was specified along with a "cell_methods" string.')
2575 if (len(trim(cell_methods))>0)
then
2576 call diag_field_add_attribute(id,
'cell_methods', trim(cell_methods))
2577 ostring = trim(cell_methods)
2580 if (
present(x_cell_method))
then
2581 if (len(trim(x_cell_method))>0)
then
2582 call get_diag_axis_name(axes%handles(1), axis_name)
2583 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(x_cell_method))
2584 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(x_cell_method)
2585 if (trim(x_cell_method)==
'mean') x_mean=.true.
2586 if (trim(x_cell_method)==
'sum') x_sum=.true.
2589 if (len(trim(axes%x_cell_method))>0)
then
2590 call get_diag_axis_name(axes%handles(1), axis_name)
2591 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%x_cell_method))
2592 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%x_cell_method)
2593 if (trim(axes%x_cell_method)==
'mean') x_mean=.true.
2594 if (trim(axes%x_cell_method)==
'sum') x_sum=.true.
2597 if (
present(y_cell_method))
then
2598 if (len(trim(y_cell_method))>0)
then
2599 call get_diag_axis_name(axes%handles(2), axis_name)
2600 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(y_cell_method))
2601 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(y_cell_method)
2602 if (trim(y_cell_method)==
'mean') y_mean=.true.
2603 if (trim(y_cell_method)==
'sum') y_sum=.true.
2606 if (len(trim(axes%y_cell_method))>0)
then
2607 call get_diag_axis_name(axes%handles(2), axis_name)
2608 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%y_cell_method))
2609 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%y_cell_method)
2610 if (trim(axes%y_cell_method)==
'mean') y_mean=.true.
2611 if (trim(axes%y_cell_method)==
'sum') y_sum=.true.
2614 if (
present(v_cell_method))
then
2615 if (
present(v_extensive))
call mom_error(fatal,
"attach_cell_methods: " // &
2616 'Vertical cell method was specified along with the vertically extensive flag.')
2617 if (len(trim(v_cell_method))>0)
then
2618 if (axes%rank==1)
then
2619 call get_diag_axis_name(axes%handles(1), axis_name)
2620 elseif (axes%rank==3)
then
2621 call get_diag_axis_name(axes%handles(3), axis_name)
2623 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(v_cell_method))
2624 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(v_cell_method)
2626 elseif (
present(v_extensive))
then
2627 if(v_extensive)
then
2628 if (axes%rank==1)
then
2629 call get_diag_axis_name(axes%handles(1), axis_name)
2630 elseif (axes%rank==3)
then
2631 call get_diag_axis_name(axes%handles(3), axis_name)
2633 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':sum')
2634 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':sum'
2637 if (len(trim(axes%v_cell_method))>0)
then
2638 if (axes%rank==1)
then
2639 call get_diag_axis_name(axes%handles(1), axis_name)
2640 elseif (axes%rank==3)
then
2641 call get_diag_axis_name(axes%handles(3), axis_name)
2643 call diag_field_add_attribute(id,
'cell_methods', trim(axis_name)//
':'//trim(axes%v_cell_method))
2644 ostring = trim(adjustl(ostring))//
' '//trim(axis_name)//
':'//trim(axes%v_cell_method)
2647 if (x_mean .and. y_mean)
then
2648 call diag_field_add_attribute(id,
'cell_methods',
'area:mean')
2649 ostring = trim(adjustl(ostring))//
' area:mean'
2650 elseif (x_sum .and. y_sum)
then
2651 call diag_field_add_attribute(id,
'cell_methods',
'area:sum')
2652 ostring = trim(adjustl(ostring))//
' area:sum'
2655 ostring = adjustl(ostring)
2656 end subroutine attach_cell_methods
2658 function register_scalar_field(module_name, field_name, init_time, diag_cs, &
2659 long_name, units, missing_value, range, standard_name, &
2660 do_not_log, err_msg, interp_method, cmor_field_name, &
2661 cmor_long_name, cmor_units, cmor_standard_name)
2662 integer :: register_scalar_field
2663 character(len=*),
intent(in) :: module_name
2665 character(len=*),
intent(in) :: field_name
2666 type(time_type),
intent(in) :: init_time
2667 type(
diag_ctrl),
intent(inout) :: diag_cs
2668 character(len=*),
optional,
intent(in) :: long_name
2669 character(len=*),
optional,
intent(in) :: units
2670 character(len=*),
optional,
intent(in) :: standard_name
2671 real,
optional,
intent(in) :: missing_value
2672 real,
optional,
intent(in) :: range(2)
2673 logical,
optional,
intent(in) :: do_not_log
2674 character(len=*),
optional,
intent(out):: err_msg
2676 character(len=*),
optional,
intent(in) :: interp_method
2678 character(len=*),
optional,
intent(in) :: cmor_field_name
2679 character(len=*),
optional,
intent(in) :: cmor_long_name
2680 character(len=*),
optional,
intent(in) :: cmor_units
2681 character(len=*),
optional,
intent(in) :: cmor_standard_name
2684 real :: mom_missing_value
2685 integer :: dm_id, fms_id
2686 type(
diag_type),
pointer :: diag => null(), cmor_diag => null()
2687 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2689 mom_missing_value = diag_cs%missing_value
2690 if (
present(missing_value)) mom_missing_value = missing_value
2696 if (diag_cs%diag_as_chksum)
then
2697 fms_id = diag_cs%num_chksum_diags + 1
2698 diag_cs%num_chksum_diags = fms_id
2701 long_name=long_name, units=units, missing_value=mom_missing_value, &
2702 range=range, standard_name=standard_name, do_not_log=do_not_log, &
2706 if (fms_id /= diag_field_not_found)
then
2707 dm_id = get_new_diag_id(diag_cs)
2708 call alloc_diag_with_id(dm_id, diag_cs, diag)
2709 call assert(
associated(diag),
'register_scalar_field: diag allocation failed')
2710 diag%fms_diag_id = fms_id
2711 diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2714 if (
present(cmor_field_name))
then
2716 posted_cmor_units =
"not provided"
2717 posted_cmor_standard_name =
"not provided"
2718 posted_cmor_long_name =
"not provided"
2722 if (
present(units)) posted_cmor_units = units
2723 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2724 if (
present(long_name)) posted_cmor_long_name = long_name
2727 if (
present(cmor_units)) posted_cmor_units = cmor_units
2728 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2729 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2732 long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2733 missing_value=mom_missing_value, range=range, &
2734 standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg)
2735 if (fms_id /= diag_field_not_found)
then
2736 if (dm_id == -1)
then
2737 dm_id = get_new_diag_id(diag_cs)
2739 call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2740 cmor_diag%fms_diag_id = fms_id
2741 cmor_diag%debug_str = trim(module_name)//
"-"//trim(cmor_field_name)
2746 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2747 call log_available_diag(
associated(diag), module_name, field_name,
'',
'', diag_cs, &
2748 long_name, units, standard_name)
2749 if (
present(cmor_field_name))
then
2750 call log_available_diag(
associated(cmor_diag), module_name, cmor_field_name, &
2751 '',
'', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2752 posted_cmor_standard_name)
2756 register_scalar_field = dm_id
2758 end function register_scalar_field
2761 function register_static_field(module_name, field_name, axes, &
2762 long_name, units, missing_value, range, mask_variant, standard_name, &
2763 do_not_log, interp_method, tile_count, &
2764 cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, &
2765 x_cell_method, y_cell_method, area_cell_method, conversion)
2766 integer :: register_static_field
2767 character(len=*),
intent(in) :: module_name
2769 character(len=*),
intent(in) :: field_name
2770 type(
axes_grp),
target,
intent(in) :: axes
2772 character(len=*),
optional,
intent(in) :: long_name
2773 character(len=*),
optional,
intent(in) :: units
2774 character(len=*),
optional,
intent(in) :: standard_name
2775 real,
optional,
intent(in) :: missing_value
2776 real,
optional,
intent(in) :: range(2)
2777 logical,
optional,
intent(in) :: mask_variant
2779 logical,
optional,
intent(in) :: do_not_log
2780 character(len=*),
optional,
intent(in) :: interp_method
2782 integer,
optional,
intent(in) :: tile_count
2783 character(len=*),
optional,
intent(in) :: cmor_field_name
2784 character(len=*),
optional,
intent(in) :: cmor_long_name
2785 character(len=*),
optional,
intent(in) :: cmor_units
2786 character(len=*),
optional,
intent(in) :: cmor_standard_name
2787 integer,
optional,
intent(in) :: area
2788 character(len=*),
optional,
intent(in) :: x_cell_method
2789 character(len=*),
optional,
intent(in) :: y_cell_method
2790 character(len=*),
optional,
intent(in) :: area_cell_method
2791 real,
optional,
intent(in) :: conversion
2794 real :: mom_missing_value
2795 type(
diag_ctrl),
pointer :: diag_cs => null()
2796 type(
diag_type),
pointer :: diag => null(), cmor_diag => null()
2797 integer :: dm_id, fms_id, cmor_id
2798 character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name
2799 character(len=9) :: axis_name
2801 mom_missing_value = axes%diag_cs%missing_value
2802 if (
present(missing_value)) mom_missing_value = missing_value
2804 diag_cs => axes%diag_cs
2809 if (diag_cs%diag_as_chksum)
then
2810 fms_id = diag_cs%num_chksum_diags + 1
2811 diag_cs%num_chksum_diags = fms_id
2813 fms_id = register_static_field_fms(module_name, field_name, axes%handles, &
2814 long_name=long_name, units=units, missing_value=mom_missing_value, &
2815 range=range, mask_variant=mask_variant, standard_name=standard_name, &
2816 do_not_log=do_not_log, &
2817 interp_method=interp_method, tile_count=tile_count, area=area)
2820 if (fms_id /= diag_field_not_found)
then
2821 dm_id = get_new_diag_id(diag_cs)
2822 call alloc_diag_with_id(dm_id, diag_cs, diag)
2823 call assert(
associated(diag),
'register_static_field: diag allocation failed')
2824 diag%fms_diag_id = fms_id
2825 diag%debug_str = trim(module_name)//
"-"//trim(field_name)
2826 if (
present(conversion)) diag%conversion_factor = conversion
2828 if (diag_cs%diag_as_chksum)
then
2831 if (
present(x_cell_method))
then
2832 call get_diag_axis_name(axes%handles(1), axis_name)
2833 call diag_field_add_attribute(fms_id,
'cell_methods', &
2834 trim(axis_name)//
':'//trim(x_cell_method))
2836 if (
present(y_cell_method))
then
2837 call get_diag_axis_name(axes%handles(2), axis_name)
2838 call diag_field_add_attribute(fms_id,
'cell_methods', &
2839 trim(axis_name)//
':'//trim(y_cell_method))
2841 if (
present(area_cell_method))
then
2842 call diag_field_add_attribute(fms_id,
'cell_methods', &
2843 'area:'//trim(area_cell_method))
2848 if (
present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum)
then
2850 posted_cmor_units =
"not provided"
2851 posted_cmor_standard_name =
"not provided"
2852 posted_cmor_long_name =
"not provided"
2856 if (
present(units)) posted_cmor_units = units
2857 if (
present(standard_name)) posted_cmor_standard_name = standard_name
2858 if (
present(long_name)) posted_cmor_long_name = long_name
2861 if (
present(cmor_units)) posted_cmor_units = cmor_units
2862 if (
present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name
2863 if (
present(cmor_long_name)) posted_cmor_long_name = cmor_long_name
2865 fms_id = register_static_field_fms(module_name, cmor_field_name, &
2866 axes%handles, long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), &
2867 missing_value=mom_missing_value, range=range, mask_variant=mask_variant, &
2868 standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, &
2869 interp_method=interp_method, tile_count=tile_count, area=area)
2870 if (fms_id /= diag_field_not_found)
then
2871 if (dm_id == -1)
then
2872 dm_id = get_new_diag_id(diag_cs)
2874 call alloc_diag_with_id(dm_id, diag_cs, cmor_diag)
2875 cmor_diag%fms_diag_id = fms_id
2876 cmor_diag%debug_str = trim(module_name)//
"-"//trim(cmor_field_name)
2877 if (
present(conversion)) cmor_diag%conversion_factor = conversion
2878 if (
present(x_cell_method))
then
2879 call get_diag_axis_name(axes%handles(1), axis_name)
2880 call diag_field_add_attribute(fms_id,
'cell_methods', trim(axis_name)//
':'//trim(x_cell_method))
2882 if (
present(y_cell_method))
then
2883 call get_diag_axis_name(axes%handles(2), axis_name)
2884 call diag_field_add_attribute(fms_id,
'cell_methods', trim(axis_name)//
':'//trim(y_cell_method))
2886 if (
present(area_cell_method))
then
2887 call diag_field_add_attribute(fms_id,
'cell_methods',
'area:'//trim(area_cell_method))
2893 if (is_root_pe() .and. diag_cs%available_diag_doc_unit > 0)
then
2894 call log_available_diag(
associated(diag), module_name, field_name,
'',
'', diag_cs, &
2895 long_name, units, standard_name)
2896 if (
present(cmor_field_name))
then
2897 call log_available_diag(
associated(cmor_diag), module_name, cmor_field_name, &
2898 '',
'', diag_cs, posted_cmor_long_name, posted_cmor_units, &
2899 posted_cmor_standard_name)
2903 register_static_field = dm_id
2905 end function register_static_field
2908 subroutine describe_option(opt_name, value, diag_CS)
2909 character(len=*),
intent(in) :: opt_name
2910 character(len=*),
intent(in) ::
value
2913 character(len=240) :: mesg
2916 len_ind = len_trim(
value)
2918 mesg =
" ! "//trim(opt_name)//
": "//trim(
value)
2919 write(diag_cs%available_diag_doc_unit,
'(a)') trim(mesg)
2920 end subroutine describe_option
2925 function ocean_register_diag(var_desc, G, diag_CS, day)
2926 integer :: ocean_register_diag
2927 type(
vardesc),
intent(in) :: var_desc
2929 type(
diag_ctrl),
intent(in),
target :: diag_cs
2930 type(time_type),
intent(in) :: day
2932 character(len=64) :: var_name
2933 character(len=48) :: units
2934 character(len=240) :: longname
2935 character(len=8) :: hor_grid, z_grid
2936 type(
axes_grp),
pointer :: axes => null()
2938 call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, &
2939 z_grid=z_grid, caller=
"ocean_register_diag")
2943 select case (z_grid)
2946 select case (hor_grid)
2948 axes => diag_cs%axesBL
2950 axes => diag_cs%axesTL
2952 axes => diag_cs%axesCuL
2954 axes => diag_cs%axesCvL
2956 axes => diag_cs%axesBL
2958 axes => diag_cs%axesTL
2960 axes => diag_cs%axesCuL
2962 axes => diag_cs%axesCvL
2964 axes => diag_cs%axeszL
2966 call mom_error(fatal,
"ocean_register_diag: " // &
2967 "unknown hor_grid component "//trim(hor_grid))
2971 select case (hor_grid)
2973 axes => diag_cs%axesBi
2975 axes => diag_cs%axesTi
2977 axes => diag_cs%axesCui
2979 axes => diag_cs%axesCvi
2981 axes => diag_cs%axesBi
2983 axes => diag_cs%axesTi
2985 axes => diag_cs%axesCui
2987 axes => diag_cs%axesCvi
2989 axes => diag_cs%axeszi
2991 call mom_error(fatal,
"ocean_register_diag: " // &
2992 "unknown hor_grid component "//trim(hor_grid))
2996 select case (hor_grid)
2998 axes => diag_cs%axesB1
3000 axes => diag_cs%axesT1
3002 axes => diag_cs%axesCu1
3004 axes => diag_cs%axesCv1
3006 axes => diag_cs%axesB1
3008 axes => diag_cs%axesT1
3010 axes => diag_cs%axesCu1
3012 axes => diag_cs%axesCv1
3014 call mom_error(fatal,
"ocean_register_diag: " // &
3015 "unknown hor_grid component "//trim(hor_grid))
3019 call mom_error(fatal,&
3020 "ocean_register_diag: unknown z_grid component "//trim(z_grid))
3023 ocean_register_diag = register_diag_field(
"ocean_model", trim(var_name), &
3024 axes, day, trim(longname), trim(units), missing_value=-1.0e+34)
3026 end function ocean_register_diag
3028 subroutine diag_mediator_infrastructure_init(err_msg)
3030 character(len=*),
optional,
intent(out) :: err_msg
3032 call diag_manager_init(err_msg=err_msg)
3033 end subroutine diag_mediator_infrastructure_init
3037 subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir)
3041 integer,
intent(in) :: nz
3043 type(
diag_ctrl),
intent(inout) :: diag_cs
3045 character(len=*),
optional,
intent(in) :: doc_file_dir
3053 integer :: ios, i, new_unit
3054 logical :: opened, new_file
3055 logical :: answers_2018, default_2018_answers
3056 character(len=8) :: this_pe
3057 character(len=240) :: doc_file, doc_file_dflt, doc_path
3058 character(len=240),
allocatable :: diag_coords(:)
3060 # include "version_variable.h"
3061 character(len=40) :: mdl =
"MOM_diag_mediator"
3062 character(len=32) :: filename_appendix =
''
3064 id_clock_diag_mediator = cpu_clock_id(
'(Ocean diagnostics framework)', grain=clock_module)
3065 id_clock_diag_remap = cpu_clock_id(
'(Ocean diagnostics remapping)', grain=clock_routine)
3066 id_clock_diag_grid_updates = cpu_clock_id(
'(Ocean diagnostics grid updates)', grain=clock_routine)
3069 allocate(diag_cs%diags(diag_alloc_chunk_size))
3070 diag_cs%next_free_diag_id = 1
3071 do i=1, diag_alloc_chunk_size
3072 call initialize_diag_type(diag_cs%diags(i))
3078 call get_param(param_file, mdl,
'NUM_DIAG_COORDS', diag_cs%num_diag_coords, &
3079 'The number of diagnostic vertical coordinates to use. '//&
3080 'For each coordinate, an entry in DIAG_COORDS must be provided.', &
3082 call get_param(param_file, mdl,
"DEFAULT_2018_ANSWERS", default_2018_answers, &
3083 "This sets the default value for the various _2018_ANSWERS parameters.", &
3085 call get_param(param_file, mdl,
"REMAPPING_2018_ANSWERS", answers_2018, &
3086 "If true, use the order of arithmetic and expressions that recover the "//&
3087 "answers from the end of 2018. Otherwise, use updated and more robust "//&
3088 "forms of the same expressions.", default=default_2018_answers)
3089 call get_param(param_file, mdl,
'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, &
3090 'If true, use a grid index coordinate convention for diagnostic axes. ',&
3093 if (diag_cs%num_diag_coords>0)
then
3094 allocate(diag_coords(diag_cs%num_diag_coords))
3095 if (diag_cs%num_diag_coords==1)
then
3096 call get_param(param_file, mdl,
'DIAG_COORDS', diag_coords, &
3097 'A list of string tuples associating diag_table modules to '//&
3098 'a coordinate definition used for diagnostics. Each string '//&
3099 'is of the form "MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME".', &
3100 default=
'z Z ZSTAR')
3102 call get_param(param_file, mdl,
'DIAG_COORDS', diag_coords, &
3103 'A list of string tuples associating diag_table modules to '//&
3104 'a coordinate definition used for diagnostics. Each string '//&
3105 'is of the form "MODULE_SUFFIX,PARAMETER_SUFFIX,COORDINATE_NAME".', &
3106 fail_if_missing=.true.)
3108 allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords))
3110 do i=1, diag_cs%num_diag_coords
3111 call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answers_2018=answers_2018)
3113 deallocate(diag_coords)
3116 call get_param(param_file, mdl,
'DIAG_MISVAL', diag_cs%missing_value, &
3117 'Set the default missing value to use for diagnostics.', &
3119 call get_param(param_file, mdl,
'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, &
3120 'Instead of writing diagnostics to the diag manager, write '//&
3121 'a text file containing the checksum (bitcount) of the array.', &
3124 if (diag_cs%diag_as_chksum) &
3125 diag_cs%num_chksum_diags = 0
3134 diag_cs%eqn_of_state => null()
3136 allocate(diag_cs%h_begin(g%isd:g%ied,g%jsd:g%jed,nz))
3137 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3138 allocate(diag_cs%h_old(g%isd:g%ied,g%jsd:g%jed,nz))
3139 diag_cs%h_old(:,:,:) = 0.0
3142 diag_cs%is = g%isc - (g%isd-1) ; diag_cs%ie = g%iec - (g%isd-1)
3143 diag_cs%js = g%jsc - (g%jsd-1) ; diag_cs%je = g%jec - (g%jsd-1)
3144 diag_cs%isd = g%isd ; diag_cs%ied = g%ied
3145 diag_cs%jsd = g%jsd ; diag_cs%jed = g%jed
3148 diag_cs%dsamp(2)%isc = g%HId2%isc - (g%HId2%isd-1) ; diag_cs%dsamp(2)%iec = g%HId2%iec - (g%HId2%isd-1)
3149 diag_cs%dsamp(2)%jsc = g%HId2%jsc - (g%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = g%HId2%jec - (g%HId2%jsd-1)
3150 diag_cs%dsamp(2)%isd = g%HId2%isd ; diag_cs%dsamp(2)%ied = g%HId2%ied
3151 diag_cs%dsamp(2)%jsd = g%HId2%jsd ; diag_cs%dsamp(2)%jed = g%HId2%jed
3152 diag_cs%dsamp(2)%isg = g%HId2%isg ; diag_cs%dsamp(2)%ieg = g%HId2%ieg
3153 diag_cs%dsamp(2)%jsg = g%HId2%jsg ; diag_cs%dsamp(2)%jeg = g%HId2%jeg
3154 diag_cs%dsamp(2)%isgB = g%HId2%isgB ; diag_cs%dsamp(2)%iegB = g%HId2%iegB
3155 diag_cs%dsamp(2)%jsgB = g%HId2%jsgB ; diag_cs%dsamp(2)%jegB = g%HId2%jegB
3158 if (is_root_pe() .and. (diag_cs%available_diag_doc_unit < 0))
then
3159 write(this_pe,
'(i6.6)') pe_here()
3160 doc_file_dflt =
"available_diags."//this_pe
3161 call get_param(param_file, mdl,
"AVAILABLE_DIAGS_FILE", doc_file, &
3162 "A file into which to write a list of all available "//&
3163 "ocean diagnostics that can be included in a diag_table.", &
3164 default=doc_file_dflt, do_not_log=(diag_cs%available_diag_doc_unit/=-1))
3165 if (len_trim(doc_file) > 0)
then
3166 new_file = .true. ;
if (diag_cs%available_diag_doc_unit /= -1) new_file = .false.
3168 do new_unit=512,42,-1
3169 inquire( new_unit, opened=opened)
3170 if (.not.opened)
exit
3172 if (opened)
call mom_error(fatal, &
3173 "diag_mediator_init failed to find an unused unit number.")
3176 if (
present(doc_file_dir))
then ;
if (len_trim(doc_file_dir) > 0)
then
3177 doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3180 diag_cs%available_diag_doc_unit = new_unit
3183 open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3184 action=
'WRITE', status=
'REPLACE', iostat=ios)
3186 open(diag_cs%available_diag_doc_unit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3187 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
3189 inquire(diag_cs%available_diag_doc_unit, opened=opened)
3190 if ((.not.opened) .or. (ios /= 0))
then
3191 call mom_error(fatal,
"Failed to open available diags file "//trim(doc_path)//
".")
3196 if (is_root_pe() .and. (diag_cs%chksum_iounit < 0) .and. diag_cs%diag_as_chksum)
then
3199 doc_file_dflt =
"chksum_diag"
3200 call get_param(param_file, mdl,
"CHKSUM_DIAG_FILE", doc_file, &
3201 "A file into which to write all checksums of the "//&
3202 "diagnostics listed in the diag_table.", &
3203 default=doc_file_dflt, do_not_log=(diag_cs%chksum_iounit/=-1))
3205 call get_filename_appendix(filename_appendix)
3206 if (len_trim(filename_appendix) > 0)
then
3207 doc_file = trim(doc_file) //
'.'//trim(filename_appendix)
3210 doc_file = trim(doc_file)//
"."//trim(adjustl(statslabel))
3213 if (len_trim(doc_file) > 0)
then
3214 new_file = .true. ;
if (diag_cs%chksum_iounit /= -1) new_file = .false.
3216 do new_unit=512,42,-1
3217 inquire( new_unit, opened=opened)
3218 if (.not.opened)
exit
3220 if (opened)
call mom_error(fatal, &
3221 "diag_mediator_init failed to find an unused unit number.")
3224 if (
present(doc_file_dir))
then ;
if (len_trim(doc_file_dir) > 0)
then
3225 doc_path = trim(slasher(doc_file_dir))//trim(doc_file)
3228 diag_cs%chksum_iounit = new_unit
3231 open(diag_cs%chksum_iounit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3232 action=
'WRITE', status=
'REPLACE', iostat=ios)
3234 open(diag_cs%chksum_iounit, file=trim(doc_path), access=
'SEQUENTIAL', form=
'FORMATTED', &
3235 action=
'WRITE', status=
'OLD', position=
'APPEND', iostat=ios)
3237 inquire(diag_cs%chksum_iounit, opened=opened)
3238 if ((.not.opened) .or. (ios /= 0))
then
3239 call mom_error(fatal,
"Failed to open checksum diags file "//trim(doc_path)//
".")
3244 end subroutine diag_mediator_init
3247 subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs)
3248 real,
dimension(:,:,:),
target,
intent(in ) :: h
3249 real,
dimension(:,:,:),
target,
intent(in ) :: t
3250 real,
dimension(:,:,:),
target,
intent(in ) :: s
3251 type(
eos_type),
target,
intent(in ) :: eqn_of_state
3252 type(
diag_ctrl),
intent(inout) :: diag_cs
3258 diag_cs%eqn_of_state => eqn_of_state
3265 subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensive, update_extensive )
3267 real,
target,
optional,
intent(in ) :: alt_h(:,:,:)
3269 real,
target,
optional,
intent(in ) :: alt_t(:,:,:)
3271 real,
target,
optional,
intent(in ) :: alt_s(:,:,:)
3273 logical,
optional,
intent(in ) :: update_intensive
3275 logical,
optional,
intent(in ) :: update_extensive
3279 real,
dimension(:,:,:),
pointer :: h_diag => null()
3280 real,
dimension(:,:,:),
pointer :: t_diag => null(), s_diag => null()
3281 logical :: update_intensive_local, update_extensive_local
3284 if (
present(alt_h))
then
3290 if (
present(alt_t))
then
3296 if (
present(alt_s))
then
3306 update_intensive_local = .true.
3307 if (
present(update_intensive)) update_intensive_local = update_intensive
3308 update_extensive_local = .false.
3309 if (
present(update_extensive)) update_extensive_local = update_extensive
3311 if (id_clock_diag_grid_updates>0)
call cpu_clock_begin(id_clock_diag_grid_updates)
3313 if (diag_cs%diag_grid_overridden)
then
3314 call mom_error(fatal,
"diag_update_remap_grids was called, but current grids in "// &
3315 "diagnostic structure have been overridden")
3318 if (update_intensive_local)
then
3319 do i=1, diag_cs%num_diag_coords
3320 call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, t_diag, s_diag, &
3321 diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h)
3324 if (update_extensive_local)
then
3325 diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:)
3326 do i=1, diag_cs%num_diag_coords
3327 call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, t_diag, s_diag, &
3328 diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive)
3332 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3335 diag_cs%h_old(:,:,:) = diag_cs%h(:,:,:)
3338 if (id_clock_diag_grid_updates>0)
call cpu_clock_end(id_clock_diag_grid_updates)
3340 end subroutine diag_update_remap_grids
3343 subroutine diag_masks_set(G, nz, diag_cs)
3345 integer,
intent(in) :: nz
3352 diag_cs%mask2dT => g%mask2dT
3353 diag_cs%mask2dBu => g%mask2dBu
3354 diag_cs%mask2dCu => g%mask2dCu
3355 diag_cs%mask2dCv => g%mask2dCv
3359 allocate(diag_cs%mask3dTL(g%isd:g%ied,g%jsd:g%jed,1:nz))
3360 allocate(diag_cs%mask3dBL(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz))
3361 allocate(diag_cs%mask3dCuL(g%IsdB:g%IedB,g%jsd:g%jed,1:nz))
3362 allocate(diag_cs%mask3dCvL(g%isd:g%ied,g%JsdB:g%JedB,1:nz))
3364 diag_cs%mask3dTL(:,:,k) = diag_cs%mask2dT(:,:)
3365 diag_cs%mask3dBL(:,:,k) = diag_cs%mask2dBu(:,:)
3366 diag_cs%mask3dCuL(:,:,k) = diag_cs%mask2dCu(:,:)
3367 diag_cs%mask3dCvL(:,:,k) = diag_cs%mask2dCv(:,:)
3369 allocate(diag_cs%mask3dTi(g%isd:g%ied,g%jsd:g%jed,1:nz+1))
3370 allocate(diag_cs%mask3dBi(g%IsdB:g%IedB,g%JsdB:g%JedB,1:nz+1))
3371 allocate(diag_cs%mask3dCui(g%IsdB:g%IedB,g%jsd:g%jed,1:nz+1))
3372 allocate(diag_cs%mask3dCvi(g%isd:g%ied,g%JsdB:g%JedB,1:nz+1))
3374 diag_cs%mask3dTi(:,:,k) = diag_cs%mask2dT(:,:)
3375 diag_cs%mask3dBi(:,:,k) = diag_cs%mask2dBu(:,:)
3376 diag_cs%mask3dCui(:,:,k) = diag_cs%mask2dCu(:,:)
3377 diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:)
3381 call downsample_diag_masks_set(g, nz, diag_cs)
3383 end subroutine diag_masks_set
3385 subroutine diag_mediator_close_registration(diag_CS)
3390 if (diag_cs%available_diag_doc_unit > -1)
then
3391 close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -2
3394 do i=1, diag_cs%num_diag_coords
3395 call diag_remap_diag_registration_closed(diag_cs%diag_remap_cs(i))
3398 end subroutine diag_mediator_close_registration
3400 subroutine diag_mediator_end(time, diag_CS, end_diag_manager)
3401 type(time_type),
intent(in) :: time
3402 type(
diag_ctrl),
intent(inout) :: diag_cs
3403 logical,
optional,
intent(in) :: end_diag_manager
3408 if (diag_cs%available_diag_doc_unit > -1)
then
3409 close(diag_cs%available_diag_doc_unit) ; diag_cs%available_diag_doc_unit = -3
3411 if (diag_cs%chksum_iounit > -1)
then
3412 close(diag_cs%chksum_iounit) ; diag_cs%chksum_iounit = -3
3415 deallocate(diag_cs%diags)
3417 do i=1, diag_cs%num_diag_coords
3418 call diag_remap_end(diag_cs%diag_remap_cs(i))
3421 call diag_grid_storage_end(diag_cs%diag_grid_temp)
3422 deallocate(diag_cs%mask3dTL)
3423 deallocate(diag_cs%mask3dBL)
3424 deallocate(diag_cs%mask3dCuL)
3425 deallocate(diag_cs%mask3dCvL)
3426 deallocate(diag_cs%mask3dTi)
3427 deallocate(diag_cs%mask3dBi)
3428 deallocate(diag_cs%mask3dCui)
3429 deallocate(diag_cs%mask3dCvi)
3430 do i=2,max_dsamp_lev
3431 deallocate(diag_cs%dsamp(i)%mask2dT)
3432 deallocate(diag_cs%dsamp(i)%mask2dBu)
3433 deallocate(diag_cs%dsamp(i)%mask2dCu)
3434 deallocate(diag_cs%dsamp(i)%mask2dCv)
3435 deallocate(diag_cs%dsamp(i)%mask3dTL)
3436 deallocate(diag_cs%dsamp(i)%mask3dBL)
3437 deallocate(diag_cs%dsamp(i)%mask3dCuL)
3438 deallocate(diag_cs%dsamp(i)%mask3dCvL)
3439 deallocate(diag_cs%dsamp(i)%mask3dTi)
3440 deallocate(diag_cs%dsamp(i)%mask3dBi)
3441 deallocate(diag_cs%dsamp(i)%mask3dCui)
3442 deallocate(diag_cs%dsamp(i)%mask3dCvi)
3445 #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__)
3446 deallocate(diag_cs%h_old)
3449 if (
present(end_diag_manager))
then
3450 if (end_diag_manager)
call diag_manager_end(time)
3453 end subroutine diag_mediator_end
3456 function i2s(a,n_in)
3459 integer,
dimension(:),
intent(in) :: a
3460 integer,
optional ,
intent(in) :: n_in
3461 character(len=15) :: i2s
3463 character(len=15) :: i2s_temp
3467 if (
present(n_in)) n = n_in
3471 write (i2s_temp,
'(I4.4)') a(i)
3472 i2s = trim(i2s) //
'_'// trim(i2s_temp)
3478 integer function get_new_diag_id(diag_cs)
3481 type(
diag_type),
dimension(:),
allocatable :: tmp
3484 if (diag_cs%next_free_diag_id >
size(diag_cs%diags))
then
3485 call assert(diag_cs%next_free_diag_id -
size(diag_cs%diags) == 1, &
3486 'get_new_diag_id: inconsistent diag id')
3490 allocate(tmp(
size(diag_cs%diags)))
3491 tmp(:) = diag_cs%diags(:)
3492 deallocate(diag_cs%diags)
3493 allocate(diag_cs%diags(
size(tmp) + diag_alloc_chunk_size))
3494 diag_cs%diags(1:
size(tmp)) = tmp(:)
3498 do i=diag_cs%next_free_diag_id,
size(diag_cs%diags)
3499 call initialize_diag_type(diag_cs%diags(i))
3503 get_new_diag_id = diag_cs%next_free_diag_id
3504 diag_cs%next_free_diag_id = diag_cs%next_free_diag_id + 1
3506 end function get_new_diag_id
3509 subroutine initialize_diag_type(diag)
3512 diag%in_use = .false.
3513 diag%fms_diag_id = -1
3516 diag%conversion_factor = 0.
3518 end subroutine initialize_diag_type
3522 subroutine alloc_diag_with_id(diag_id, diag_cs, diag)
3523 integer,
intent(in ) :: diag_id
3524 type(
diag_ctrl),
target,
intent(inout) :: diag_cs
3527 type(
diag_type),
pointer :: tmp => null()
3529 if (.not. diag_cs%diags(diag_id)%in_use)
then
3530 diag => diag_cs%diags(diag_id)
3533 tmp => diag_cs%diags(diag_id)%next
3534 diag_cs%diags(diag_id)%next => diag
3537 diag%in_use = .true.
3539 end subroutine alloc_diag_with_id
3542 subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, &
3543 diag_CS, long_name, units, standard_name)
3544 logical,
intent(in) :: used
3545 character(len=*),
intent(in) :: module_name
3546 character(len=*),
intent(in) :: field_name
3547 character(len=*),
intent(in) :: cell_methods_string
3548 character(len=*),
intent(in) :: comment
3550 character(len=*),
optional,
intent(in) :: long_name
3551 character(len=*),
optional,
intent(in) :: units
3552 character(len=*),
optional,
intent(in) :: standard_name
3554 character(len=240) :: mesg
3557 mesg =
'"'//trim(module_name)//
'", "'//trim(field_name)//
'" [Used]'
3559 mesg =
'"'//trim(module_name)//
'", "'//trim(field_name)//
'" [Unused]'
3561 if (len(trim((comment)))>0)
then
3562 write(diag_cs%available_diag_doc_unit,
'(a,x,"(",a,")")') trim(mesg),trim(comment)
3564 write(diag_cs%available_diag_doc_unit,
'(a)') trim(mesg)
3566 if (
present(long_name))
call describe_option(
"long_name", long_name, diag_cs)
3567 if (
present(units))
call describe_option(
"units", units, diag_cs)
3568 if (
present(standard_name)) &
3569 call describe_option(
"standard_name", standard_name, diag_cs)
3570 if (len(trim((cell_methods_string)))>0) &
3571 call describe_option(
"cell_methods", trim(cell_methods_string), diag_cs)
3573 end subroutine log_available_diag
3576 subroutine log_chksum_diag(docunit, description, chksum)
3577 integer,
intent(in) :: docunit
3578 character(len=*),
intent(in) :: description
3579 integer,
intent(in) :: chksum
3581 write(docunit,
'(a,x,i9.8)') description,
chksum
3584 end subroutine log_chksum_diag
3587 subroutine diag_grid_storage_init(grid_storage, G, diag)
3594 grid_storage%num_diag_coords = diag%num_diag_coords
3597 if (grid_storage%num_diag_coords < 1)
return
3600 allocate(grid_storage%h_state(g%isd:g%ied,g%jsd:g%jed, g%ke))
3602 allocate(grid_storage%diag_grids(diag%num_diag_coords))
3604 do m = 1, diag%num_diag_coords
3605 nz = diag%diag_remap_cs(m)%nz
3606 allocate(grid_storage%diag_grids(m)%h(g%isd:g%ied,g%jsd:g%jed, nz))
3609 end subroutine diag_grid_storage_init
3612 subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag)
3614 real,
dimension(:,:,:),
intent(in) :: h_state
3620 if (grid_storage%num_diag_coords < 1)
return
3622 grid_storage%h_state(:,:,:) = h_state(:,:,:)
3623 do m = 1,grid_storage%num_diag_coords
3624 if (diag%diag_remap_cs(m)%nz > 0) &
3625 grid_storage%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3628 end subroutine diag_copy_diag_to_storage
3631 subroutine diag_copy_storage_to_diag(diag, grid_storage)
3638 if (grid_storage%num_diag_coords < 1)
return
3640 diag%diag_grid_overridden = .true.
3641 do m = 1,grid_storage%num_diag_coords
3642 if (diag%diag_remap_cs(m)%nz > 0) &
3643 diag%diag_remap_cs(m)%h(:,:,:) = grid_storage%diag_grids(m)%h(:,:,:)
3646 end subroutine diag_copy_storage_to_diag
3649 subroutine diag_save_grids(diag)
3655 if (diag%num_diag_coords < 1)
return
3657 do m = 1,diag%num_diag_coords
3658 if (diag%diag_remap_cs(m)%nz > 0) &
3659 diag%diag_grid_temp%diag_grids(m)%h(:,:,:) = diag%diag_remap_cs(m)%h(:,:,:)
3662 end subroutine diag_save_grids
3665 subroutine diag_restore_grids(diag)
3671 if (diag%num_diag_coords < 1)
return
3673 diag%diag_grid_overridden = .false.
3674 do m = 1,diag%num_diag_coords
3675 if (diag%diag_remap_cs(m)%nz > 0) &
3676 diag%diag_remap_cs(m)%h(:,:,:) = diag%diag_grid_temp%diag_grids(m)%h(:,:,:)
3679 end subroutine diag_restore_grids
3682 subroutine diag_grid_storage_end(grid_storage)
3688 if (grid_storage%num_diag_coords < 1)
return
3691 deallocate(grid_storage%h_state)
3693 do m = 1, grid_storage%num_diag_coords
3694 deallocate(grid_storage%diag_grids(m)%h)
3697 deallocate(grid_storage%diag_grids)
3698 end subroutine diag_grid_storage_end
3702 subroutine downsample_diag_masks_set(G, nz, diag_cs)
3704 integer,
intent(in) :: nz
3708 integer :: i,j,k,ii,jj,dl
3724 do dl=2,max_dsamp_lev
3726 call downsample_mask(g%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,g%isc, g%jsc, &
3727 g%HId2%isc, g%HId2%iec, g%HId2%jsc, g%HId2%jec, g%HId2%isd, g%HId2%ied, g%HId2%jsd, g%HId2%jed)
3728 call downsample_mask(g%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,g%IscB,g%JscB, &
3729 g%HId2%IscB,g%HId2%IecB,g%HId2%JscB,g%HId2%JecB,g%HId2%IsdB,g%HId2%IedB,g%HId2%JsdB,g%HId2%JedB)
3730 call downsample_mask(g%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,g%IscB,g%JscB, &
3731 g%HId2%IscB,g%HId2%IecB,g%HId2%jsc, g%HId2%jec,g%HId2%IsdB,g%HId2%IedB,g%HId2%jsd, g%HId2%jed)
3732 call downsample_mask(g%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,g%isc ,g%JscB, &
3733 g%HId2%isc ,g%HId2%iec, g%HId2%JscB,g%HId2%JecB,g%HId2%isd ,g%HId2%ied, g%HId2%JsdB,g%HId2%JedB)
3736 allocate(diag_cs%dsamp(dl)%mask3dTL(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz))
3737 allocate(diag_cs%dsamp(dl)%mask3dBL(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz))
3738 allocate(diag_cs%dsamp(dl)%mask3dCuL(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz))
3739 allocate(diag_cs%dsamp(dl)%mask3dCvL(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz))
3741 diag_cs%dsamp(dl)%mask3dTL(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3742 diag_cs%dsamp(dl)%mask3dBL(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3743 diag_cs%dsamp(dl)%mask3dCuL(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3744 diag_cs%dsamp(dl)%mask3dCvL(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3746 allocate(diag_cs%dsamp(dl)%mask3dTi(g%HId2%isd:g%HId2%ied,g%HId2%jsd:g%HId2%jed,1:nz+1))
3747 allocate(diag_cs%dsamp(dl)%mask3dBi(g%HId2%IsdB:g%HId2%IedB,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3748 allocate(diag_cs%dsamp(dl)%mask3dCui(g%HId2%IsdB:g%HId2%IedB,g%HId2%jsd:g%HId2%jed,1:nz+1))
3749 allocate(diag_cs%dsamp(dl)%mask3dCvi(g%HId2%isd:g%HId2%ied,g%HId2%JsdB:g%HId2%JedB,1:nz+1))
3751 diag_cs%dsamp(dl)%mask3dTi(:,:,k) = diag_cs%dsamp(dl)%mask2dT(:,:)
3752 diag_cs%dsamp(dl)%mask3dBi(:,:,k) = diag_cs%dsamp(dl)%mask2dBu(:,:)
3753 diag_cs%dsamp(dl)%mask3dCui(:,:,k) = diag_cs%dsamp(dl)%mask2dCu(:,:)
3754 diag_cs%dsamp(dl)%mask3dCvi(:,:,k) = diag_cs%dsamp(dl)%mask2dCv(:,:)
3757 end subroutine downsample_diag_masks_set
3761 subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev)
3762 integer,
intent(in) :: fo1
3763 integer,
intent(in) :: fo2
3764 integer,
intent(in) :: dl
3766 integer,
intent(out) :: isv
3767 integer,
intent(out) :: iev
3768 integer,
intent(out) :: jsv
3769 integer,
intent(out) :: jev
3771 integer :: dszi,cszi,dszj,cszj,f1,f2
3772 character(len=500) :: mesg
3773 logical,
save :: first_check = .true.
3781 if(first_check)
then
3782 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
3783 write (mesg,*)
"Non-commensurate downsampled domain is not supported. "//&
3784 "Please choose a layout such that NIGLOBAL/Layout_X and NJGLOBAL/Layout_Y are both divisible by dl=",dl,&
3785 " Current domain extents: ", diag_cs%is,diag_cs%ie, diag_cs%js,diag_cs%je
3786 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3788 first_check = .false.
3791 cszi = diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc +1 ; dszi = diag_cs%dsamp(dl)%ied-diag_cs%dsamp(dl)%isd +1
3792 cszj = diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc +1 ; dszj = diag_cs%dsamp(dl)%jed-diag_cs%dsamp(dl)%jsd +1
3793 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec
3794 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
3798 if (diag_cs%G%symmetric)
then
3799 f1 = f1 + mod(fo1,dl)
3800 f2 = f2 + mod(fo2,dl)
3802 if ( f1 == dszi )
then
3803 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec
3805 elseif ( f1 == dszi + 1 )
then
3806 isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1
3807 elseif ( f1 == cszi)
then
3808 isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +1
3809 elseif ( f1 == cszi + 1 )
then
3810 isv = 1 ; iev = (diag_cs%dsamp(dl)%iec-diag_cs%dsamp(dl)%isc) +2
3812 write (mesg,*)
" peculiar size ",f1,
" in i-direction\n"//&
3813 "does not match one of ", cszi, cszi+1, dszi, dszi+1
3814 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3816 if ( f2 == dszj )
then
3817 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec
3818 elseif ( f2 == dszj + 1 )
then
3819 jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec+1
3820 elseif ( f2 == cszj)
then
3821 jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +1
3822 elseif ( f2 == cszj + 1 )
then
3823 jsv = 1 ; jev = (diag_cs%dsamp(dl)%jec-diag_cs%dsamp(dl)%jsc) +2
3825 write (mesg,*)
" peculiar size ",f2,
" in j-direction\n"//&
3826 "does not match one of ", cszj, cszj+1, dszj, dszj+1
3827 call mom_error(fatal,
"downsample_diag_indices_get: "//trim(mesg))
3829 end subroutine downsample_diag_indices_get
3834 subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3835 real,
dimension(:,:,:),
pointer :: locfield
3836 real,
dimension(:,:,:),
allocatable,
intent(inout) :: locfield_dsamp
3839 integer,
intent(in) :: dl
3840 integer,
intent(inout) :: isv
3841 integer,
intent(inout) :: iev
3842 integer,
intent(inout) :: jsv
3843 integer,
intent(inout) :: jev
3844 real,
optional,
target,
intent(in) :: mask(:,:,:)
3846 real,
dimension(:,:,:),
pointer :: locmask
3847 integer :: f1,f2,isv_o,jsv_o
3857 call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3859 if (
present(mask))
then
3861 elseif (
associated(diag%axes%mask3d))
then
3862 locmask => diag%axes%mask3d
3864 call mom_error(fatal,
"downsample_diag_field_3d: Cannot downsample without a mask!!! ")
3867 call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs, diag, &
3868 isv_o,jsv_o,isv,iev,jsv,jev)
3870 end subroutine downsample_diag_field_3d
3875 subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask)
3876 real,
dimension(:,:),
pointer :: locfield
3877 real,
dimension(:,:),
allocatable,
intent(inout) :: locfield_dsamp
3880 integer,
intent(in) :: dl
3881 integer,
intent(inout) :: isv
3882 integer,
intent(inout) :: iev
3883 integer,
intent(inout) :: jsv
3884 integer,
intent(inout) :: jev
3885 real,
optional,
target,
intent(in) :: mask(:,:)
3887 real,
dimension(:,:),
pointer :: locmask
3888 integer :: f1,f2,isv_o,jsv_o
3898 call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev)
3900 if (
present(mask))
then
3902 elseif (
associated(diag%axes%mask2d))
then
3903 locmask => diag%axes%mask2d
3905 call mom_error(fatal,
"downsample_diag_field_2d: Cannot downsample without a mask!!! ")
3908 call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, &
3909 isv_o,jsv_o,isv,iev,jsv,jev)
3911 end subroutine downsample_diag_field_2d
3950 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)
3951 real,
dimension(:,:,:),
pointer :: field_in
3952 real,
dimension(:,:,:),
allocatable :: field_out
3953 integer,
intent(in) :: dl
3954 integer,
intent(in) :: method
3955 real,
dimension(:,:,:),
pointer :: mask
3958 integer,
intent(in) :: isv_o
3959 integer,
intent(in) :: jsv_o
3960 integer,
intent(in) :: isv_d
3961 integer,
intent(in) :: iev_d
3962 integer,
intent(in) :: jsv_d
3963 integer,
intent(in) :: jev_d
3965 character(len=240) :: mesg
3966 integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
3968 real :: ave,total_weight,weight
3973 ks = 1 ; ke =
size(field_in,3)
3974 eps_face = 1.0e-20 * diag_cs%G%US%m_to_L * diag_cs%GV%m_to_H
3975 eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2
3976 eps_vol = 1.0e-20 * diag_cs%G%US%m_to_L**2 * diag_cs%GV%m_to_H
3981 f_in1 =
size(field_in,1)
3982 f_in2 =
size(field_in,2)
3986 if (diag_cs%G%symmetric)
then
3987 f1 = f1 + mod(f_in1,dl)
3988 f2 = f2 + mod(f_in2,dl)
3990 allocate(field_out(1:f1,1:f2,ks:ke))
3993 if (method == mmm)
then
3994 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
3995 i0 = isv_o+dl*(i-isv_d)
3996 j0 = jsv_o+dl*(j-jsv_d)
3999 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4001 weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k)
4002 total_weight = total_weight + weight
4003 ave = ave+field_in(ii,jj,k) * weight
4005 field_out(i,j,k) = ave/(total_weight + eps_vol)
4007 elseif (method == sss)
then
4008 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4009 i0 = isv_o+dl*(i-isv_d)
4010 j0 = jsv_o+dl*(j-jsv_d)
4012 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4013 weight = mask(ii,jj,k)
4014 ave = ave+field_in(ii,jj,k)*weight
4016 field_out(i,j,k) = ave
4018 elseif(method == mmp .or. method == mms)
then
4019 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4020 i0 = isv_o+dl*(i-isv_d)
4021 j0 = jsv_o+dl*(j-jsv_d)
4024 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4026 weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj)
4027 total_weight = total_weight + weight
4028 ave = ave+field_in(ii,jj,k)*weight
4030 field_out(i,j,k) = ave / (total_weight+eps_area)
4032 elseif(method == pmm)
then
4033 do k= ks,ke ;
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)
4040 weight =mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k)
4041 total_weight = total_weight +weight
4042 ave=ave+field_in(ii,jj,k)*weight
4044 field_out(i,j,k) = ave/(total_weight+eps_face)
4046 elseif(method == pss)
then
4047 do k= ks,ke ;
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)
4053 weight =mask(ii,jj,k)
4054 ave=ave+field_in(ii,jj,k)*weight
4056 field_out(i,j,k) = ave
4058 elseif(method == sps)
then
4059 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4060 i0 = isv_o+dl*(i-isv_d)
4061 j0 = jsv_o+dl*(j-jsv_d)
4065 weight =mask(ii,jj,k)
4066 ave=ave+field_in(ii,jj,k)*weight
4068 field_out(i,j,k) = ave
4070 elseif(method == mpm)
then
4071 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4072 i0 = isv_o+dl*(i-isv_d)
4073 j0 = jsv_o+dl*(j-jsv_d)
4078 weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k)
4079 total_weight = total_weight + weight
4080 ave=ave+field_in(ii,jj,k)*weight
4082 field_out(i,j,k) = ave/(total_weight+eps_face)
4084 elseif(method == msk)
then
4085 field_out(:,:,:) = 0.0
4086 do k= ks,ke ;
do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4087 i0 = isv_o+dl*(i-isv_d)
4088 j0 = jsv_o+dl*(j-jsv_d)
4090 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4091 ave=ave+field_in(ii,jj,k)
4093 if(ave > 0.0) field_out(i,j,k)=1.0
4096 write (mesg,*)
" unknown sampling method: ",method
4097 call mom_error(fatal,
"downsample_field_3d: "//trim(mesg)//
" "//trim(diag%debug_str))
4100 end subroutine downsample_field_3d
4105 subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, &
4106 isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d)
4107 real,
dimension(:,:),
pointer :: field_in
4108 real,
dimension(:,:),
allocatable :: field_out
4109 integer,
intent(in) :: dl
4110 integer,
intent(in) :: method
4111 real,
dimension(:,:),
pointer :: mask
4114 integer,
intent(in) :: isv_o
4115 integer,
intent(in) :: jsv_o
4116 integer,
intent(in) :: isv_d
4117 integer,
intent(in) :: iev_d
4118 integer,
intent(in) :: jsv_d
4119 integer,
intent(in) :: jev_d
4121 character(len=240) :: mesg
4122 integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2
4123 real :: ave, total_weight, weight
4124 real :: epsilon = 1.0e-20
4128 eps_len = 1.0e-20 * diag_cs%G%US%m_to_L
4129 eps_area = 1.0e-20 * diag_cs%G%US%m_to_L**2
4135 f_in1 =
size(field_in,1)
4136 f_in2 =
size(field_in,2)
4140 if (diag_cs%G%symmetric)
then
4141 f1 = f1 + mod(f_in1,dl)
4142 f2 = f2 + mod(f_in2,dl)
4144 allocate(field_out(1:f1,1:f2))
4146 if (method == mmp)
then
4147 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4148 i0 = isv_o+dl*(i-isv_d)
4149 j0 = jsv_o+dl*(j-jsv_d)
4152 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4154 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj)
4155 total_weight = total_weight + weight
4156 ave = ave+field_in(ii,jj)*weight
4158 field_out(i,j) = ave/(total_weight + eps_area)
4160 elseif(method == ssp)
then
4161 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4162 i0 = isv_o+dl*(i-isv_d)
4163 j0 = jsv_o+dl*(j-jsv_d)
4166 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4168 weight = mask(ii,jj)
4169 total_weight = total_weight + weight
4170 ave=ave+field_in(ii,jj)*weight
4172 field_out(i,j) = ave/(total_weight+epsilon)
4174 elseif(method == psp)
then
4175 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4176 i0 = isv_o+dl*(i-isv_d)
4177 j0 = jsv_o+dl*(j-jsv_d)
4182 weight = mask(ii,jj)
4183 total_weight = total_weight +weight
4184 ave=ave+field_in(ii,jj)*weight
4186 field_out(i,j) = ave/(total_weight+epsilon)
4188 elseif(method == spp)
then
4189 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4190 i0 = isv_o+dl*(i-isv_d)
4191 j0 = jsv_o+dl*(j-jsv_d)
4196 weight = mask(ii,jj)
4197 total_weight = total_weight +weight
4198 ave=ave+field_in(ii,jj)*weight
4200 field_out(i,j) = ave/(total_weight+epsilon)
4202 elseif(method == pmp)
then
4203 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4204 i0 = isv_o+dl*(i-isv_d)
4205 j0 = jsv_o+dl*(j-jsv_d)
4210 weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)
4211 total_weight = total_weight +weight
4212 ave=ave+field_in(ii,jj)*weight
4214 field_out(i,j) = ave/(total_weight+eps_len)
4216 elseif(method == mpp)
then
4217 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4218 i0 = isv_o+dl*(i-isv_d)
4219 j0 = jsv_o+dl*(j-jsv_d)
4224 weight = mask(ii,jj)* diag_cs%G%dxCv(ii,jj)
4225 total_weight = total_weight +weight
4226 ave=ave+field_in(ii,jj)*weight
4228 field_out(i,j) = ave/(total_weight+eps_len)
4230 elseif(method == msk)
then
4231 field_out(:,:) = 0.0
4232 do j=jsv_d,jev_d ;
do i=isv_d,iev_d
4233 i0 = isv_o+dl*(i-isv_d)
4234 j0 = jsv_o+dl*(j-jsv_d)
4236 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4237 ave=ave+field_in(ii,jj)
4239 if(ave > 0.0) field_out(i,j)=1.0
4242 write (mesg,*)
" unknown sampling method: ",method
4243 call mom_error(fatal,
"downsample_field_2d: "//trim(mesg)//
" "//trim(diag%debug_str))
4246 end subroutine downsample_field_2d
4251 subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4252 isd_d, ied_d, jsd_d, jed_d)
4253 real,
dimension(:,:),
intent(in) :: field_in
4254 real,
dimension(:,:),
pointer :: field_out
4255 integer,
intent(in) :: dl
4256 integer,
intent(in) :: isc_o
4257 integer,
intent(in) :: jsc_o
4258 integer,
intent(in) :: isc_d
4259 integer,
intent(in) :: iec_d
4260 integer,
intent(in) :: jsc_d
4261 integer,
intent(in) :: jec_d
4262 integer,
intent(in) :: isd_d
4263 integer,
intent(in) :: ied_d
4264 integer,
intent(in) :: jsd_d
4265 integer,
intent(in) :: jed_d
4267 integer :: i,j,ii,jj,i0,j0
4268 real :: tot_non_zero
4270 allocate(field_out(isd_d:ied_d,jsd_d:jed_d))
4271 field_out(:,:) = 0.0
4272 do j=jsc_d,jec_d ;
do i=isc_d,iec_d
4273 i0 = isc_o+dl*(i-isc_d)
4274 j0 = jsc_o+dl*(j-jsc_d)
4276 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4277 tot_non_zero = tot_non_zero + field_in(ii,jj)
4279 if(tot_non_zero > 0.0) field_out(i,j)=1.0
4281 end subroutine downsample_mask_2d
4286 subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, &
4287 isd_d, ied_d, jsd_d, jed_d)
4288 real,
dimension(:,:,:),
intent(in) :: field_in
4289 real,
dimension(:,:,:),
pointer :: field_out
4290 integer,
intent(in) :: dl
4291 integer,
intent(in) :: isc_o
4292 integer,
intent(in) :: jsc_o
4293 integer,
intent(in) :: isc_d
4294 integer,
intent(in) :: iec_d
4295 integer,
intent(in) :: jsc_d
4296 integer,
intent(in) :: jec_d
4297 integer,
intent(in) :: isd_d
4298 integer,
intent(in) :: ied_d
4299 integer,
intent(in) :: jsd_d
4300 integer,
intent(in) :: jed_d
4302 integer :: i,j,ii,jj,i0,j0,k,ks,ke
4303 real :: tot_non_zero
4305 ks = lbound(field_in,3) ; ke = ubound(field_in,3)
4306 allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke))
4307 field_out(:,:,:) = 0.0
4308 do k= ks,ke ;
do j=jsc_d,jec_d ;
do i=isc_d,iec_d
4309 i0 = isc_o+dl*(i-isc_d)
4310 j0 = jsc_o+dl*(j-jsc_d)
4312 do jj=j0,j0+dl-1 ;
do ii=i0,i0+dl-1
4313 tot_non_zero = tot_non_zero + field_in(ii,jj,k)
4315 if(tot_non_zero > 0.0) field_out(i,j,k)=1.0
4317 end subroutine downsample_mask_3d