From 2f1c376d3afd7b256417586fad952482d092e4ac Mon Sep 17 00:00:00 2001 From: uramirez8707 <49168881+uramirez8707@users.noreply.github.com> Date: Tue, 15 Aug 2023 07:42:03 -0400 Subject: [PATCH] Modern diag manager: Refactor buffers (#1332) * refactor the buffer to always save the data as 5d * rename the output buffer type --- diag_manager/fms_diag_file_object.F90 | 6 +- diag_manager/fms_diag_object.F90 | 68 +- diag_manager/fms_diag_output_buffer.F90 | 1610 +++----------------- test_fms/diag_manager/test_diag_buffer.F90 | 295 ++-- 4 files changed, 351 insertions(+), 1628 deletions(-) diff --git a/diag_manager/fms_diag_file_object.F90 b/diag_manager/fms_diag_file_object.F90 index 84c3f3980e..665a6f1683 100644 --- a/diag_manager/fms_diag_file_object.F90 +++ b/diag_manager/fms_diag_file_object.F90 @@ -45,7 +45,7 @@ module fms_diag_file_object_mod fmsDiagFullAxis_type, define_subaxis, define_diurnal_axis, & fmsDiagDiurnalAxis_type, create_new_z_subaxis use fms_diag_field_object_mod, only: fmsDiagField_type -use fms_diag_output_buffer_mod, only: fmsDiagOutputBufferContainer_type, fmsDiagOutputBuffer_class +use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type use mpp_mod, only: mpp_get_current_pelist, mpp_npes, mpp_root_pe, mpp_pe, mpp_error, FATAL, stdout, & uppercase, lowercase @@ -714,7 +714,7 @@ subroutine add_axes(this, axis_ids, diag_axis, naxis, yaml_id, buffer_id, output integer, intent(in) :: yaml_id !< Yaml id of the field section for !! this var integer, intent(in) :: buffer_id !< ID of the buffer - type(fmsDiagOutputBufferContainer_type), intent(inout) :: output_buffers(:) !< Array of output buffers + type(fmsDiagOutputBuffer_type), intent(inout) :: output_buffers(:) !< Array of output buffers type(diagYamlFilesVar_type), pointer :: field_yaml !< pointer to the yaml entry @@ -1124,7 +1124,7 @@ end subroutine write_time_metadata subroutine write_field_data(this, field_obj, buffer_obj) class(fmsDiagFileContainer_type), intent(in), target :: this !< The diag file object to write to type(fmsDiagField_type), intent(in), target :: field_obj(:) !< The field object to write from - type(fmsDiagOutputBufferContainer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data + type(fmsDiagOutputBuffer_type), intent(in), target :: buffer_obj(:) !< The buffer object with the data class(fmsDiagFile_type), pointer :: diag_file !< Diag_file object to open class(FmsNetcdfFile_t), pointer :: fileobj !< Fileobj to write to diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 208be4b2f4..789b6e55e6 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -54,7 +54,7 @@ module fms_diag_object_mod !TODO: Remove FMS prefix from variables in this type class(fmsDiagFileContainer_type), allocatable :: FMS_diag_files (:) !< array of diag files class(fmsDiagField_type), allocatable :: FMS_diag_fields(:) !< Array of diag fields - type(fmsDiagOutputBufferContainer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects + type(fmsDiagOutputBuffer_type), allocatable :: FMS_diag_output_buffers(:) !< array of output buffer objects !! one for each variable in the diag_table.yaml integer, private :: registered_buffers = 0 !< number of registered buffers, per dimension class(fmsDiagAxisContainer_type), allocatable :: diag_axis(:) !< Array of diag_axis @@ -150,9 +150,7 @@ subroutine fms_diag_object_end (this, time) call this%fms_diag_do_io(is_end_of_run=.true.) !TODO: Deallocate diag object arrays and clean up all memory do i=1, size(this%FMS_diag_output_buffers) - if(allocated(this%FMS_diag_output_buffers(i)%diag_buffer_obj)) then - call this%FMS_diag_output_buffers(i)%diag_buffer_obj%flush_buffer() - endif + call this%FMS_diag_output_buffers(i)%flush_buffer() enddo deallocate(this%FMS_diag_output_buffers) this%axes_initialized = fms_diag_axis_object_end(this%diag_axis) @@ -851,11 +849,11 @@ function get_diag_buffer(this, bufferid) & result(rslt) class(fmsDiagObject_type), intent(in) :: this integer, intent(in) :: bufferid - class(fmsDiagOutputBuffer_class),allocatable:: rslt + class(fmsDiagOutputBuffer_type),allocatable:: rslt if( (bufferid .gt. UBOUND(this%FMS_diag_output_buffers, 1)) .or. & (bufferid .lt. LBOUND(this%FMS_diag_output_buffers, 1))) & call mpp_error(FATAL, 'get_diag_bufer: invalid bufferid given') - rslt = this%FMS_diag_output_buffers(bufferid)%diag_buffer_obj + rslt = this%FMS_diag_output_buffers(bufferid) end function #endif @@ -999,9 +997,9 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) integer :: ndims !< Number of dimensions in the input field data integer :: buffer_id !< Buffer index of FMS_diag_buffers integer :: num_diurnal_samples !< Number of diurnal samples from diag_yaml - integer, allocatable :: axes_length(:) !< Length of each axis + integer :: axes_length(5) !< Length of each axis integer :: i, j !< For looping - class(fmsDiagOutputBuffer_class), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class + class(fmsDiagOutputBuffer_type), pointer :: ptr_diag_buffer_obj !< Pointer to the buffer class class(DiagYamlFilesVar_type), pointer :: ptr_diag_field_yaml !< Pointer to a field from yaml fields integer, allocatable :: axis_ids(:) !< Pointer to indices of axes of the field variable integer :: var_type !< Stores type of the field data (r4, r8, i4, i8, and string) represented as an integer. @@ -1059,13 +1057,7 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) ptr_diag_field_yaml => diag_yaml%diag_fields(yaml_id) num_diurnal_samples = ptr_diag_field_yaml%get_n_diurnal() !< Get number of diurnal samples - ! If diurnal axis exists, fill lengths of axes. - if (num_diurnal_samples .ne. 0) then - allocate(axes_length(ndims + 1)) !< Include extra length for the diurnal axis - else - allocate(axes_length(ndims)) - endif - + axes_length = 1 do j = 1, ndims axes_length(j) = this%fms_get_axis_length(axis_ids(j)) enddo @@ -1075,52 +1067,12 @@ subroutine allocate_diag_field_output_buffers(this, field_data, field_id) ndims = ndims + 1 !< Add one more dimension for the diurnal axis endif - ! Allocates diag_buffer_obj to the correct outputBuffer type based on the dimension: - ! outputBuffer0d_type, outputBuffer1d_type, outputBuffer2d_type, outputBuffer3d_type, - ! outputBuffer4d_type or outputBuffer5d_type. - if (.not. allocated(this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj)) then - call fms_diag_output_buffer_create_container(ndims, this%FMS_diag_output_buffers(buffer_id)) - end if - - ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id)%diag_buffer_obj - - select type (ptr_diag_buffer_obj) - type is (outputBuffer0d_type) !< Scalar buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), & !< If scalar field variable - this%FMS_diag_fields(field_id)%get_varname()) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - type is (outputBuffer1d_type) !< 1D buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1), & - this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - type is (outputBuffer2d_type) !< 2D buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:2), & + ptr_diag_buffer_obj => this%FMS_diag_output_buffers(buffer_id) + call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), ndims, axes_length(1:5), & this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - type is (outputBuffer3d_type) !< 3D buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:3), & - this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - type is (outputBuffer4d_type) !< 4D buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:4), & - this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - type is (outputBuffer5d_type) !< 5D buffer - if (allocated(ptr_diag_buffer_obj%buffer)) cycle !< If allocated, loop back - call ptr_diag_buffer_obj%allocate_buffer(field_data(1, 1, 1, 1), axes_length(1:5), & - this%FMS_diag_fields(field_id)%get_varname(), num_diurnal_samples) - call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) - class default - call mpp_error( FATAL, 'allocate_diag_field_output_buffers: invalid buffer type') - end select + call ptr_diag_buffer_obj%initialize_buffer(missing_value, var_name) if (allocated(axis_ids)) deallocate(axis_ids) - deallocate(axes_length) enddo this%FMS_diag_fields(field_id)%buffer_allocated = .true. diff --git a/diag_manager/fms_diag_output_buffer.F90 b/diag_manager/fms_diag_output_buffer.F90 index 3f2e1db095..7c2e706908 100644 --- a/diag_manager/fms_diag_output_buffer.F90 +++ b/diag_manager/fms_diag_output_buffer.F90 @@ -37,34 +37,20 @@ module fms_diag_output_buffer_mod private -!> @brief Object that holds buffered data and other diagnostics -!! Abstract to ensure use through its extensions(buffer0-5d types) -type, abstract :: fmsDiagOutputBuffer_class - integer, allocatable, private :: buffer_id !< index in buffer list - integer, allocatable, public :: num_elements(:) !< used in time-averaging - class(*), allocatable, public :: count_0d(:) !< used in time-averaging along with - !! counter which is stored in the child types (bufferNd) - integer(i4_kind), public :: buffer_type ! holds an allocated buffer0-5d object -type :: fmsDiagOutputBufferContainer_type - class(fmsDiagOutputBuffer_class), allocatable :: diag_buffer_obj !< any 0-5d buffer object - integer, allocatable :: axis_ids(:) !< Axis ids for the buffer - integer :: field_id !< The id of the field the buffer belongs to - integer :: yaml_id !< The id of the yaml id the buffer belongs to +type :: fmsDiagOutputBuffer_type + integer :: buffer_id !< index in buffer list + integer(i4_kind) :: buffer_type !< set to allocated data type & kind value, one of i4,i8,r4,r8 + class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array + integer :: ndim !< Number of dimensions for each variable + integer, allocatable :: buffer_dims(:) !< holds the size of each dimension in the buffer + class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions + integer, allocatable :: num_elements(:) !< used in time-averaging + class(*), allocatable :: count_0d(:) !< used in time-averaging along with + !! counter which is stored in the child types (bufferNd) + integer, allocatable :: axis_ids(:) !< Axis ids for the buffer + integer :: field_id !< The id of the field the buffer belongs to + integer :: yaml_id !< The id of the yaml id the buffer belongs to contains procedure :: add_axis_ids @@ -78,89 +64,18 @@ module fms_diag_output_buffer_mod procedure :: write_buffer_wrapper_netcdf procedure :: write_buffer_wrapper_domain procedure :: write_buffer_wrapper_u -end type - -!> Scalar buffer type to extend fmsDiagBufferContainer_type -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer0d_type - class(*), allocatable :: buffer(:) !< "scalar" numeric buffer value - !! will only be allocated to hold 1 value - class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_0d - procedure :: initialize_buffer => initialize_buffer_0d - procedure :: add_to_buffer => add_to_buffer_0d - procedure :: get_buffer => get_0d - -end type outputBuffer0d_type - -!> 1D buffer type to extend fmsDiagBuffer_class -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer1d_type - class(*), allocatable :: buffer(:) !< 1D numeric data array - class(*), allocatable :: counter(:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_1d - procedure :: initialize_buffer => initialize_buffer_1d - procedure :: add_to_buffer => add_to_buffer_1d - procedure :: get_buffer => get_1d -end type outputBuffer1d_type - -!> 2D buffer type to extend fmsDiagBuffer_class -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer2d_type - class(*), allocatable :: buffer(:,:) !< 2D numeric data array - class(*), allocatable :: counter(:,:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_2d - procedure :: initialize_buffer => initialize_buffer_2d - procedure :: add_to_buffer => add_to_buffer_2d - procedure :: get_buffer => get_2d -end type outputBuffer2d_type - -!> 3D buffer type to extend fmsDiagBuffer_class -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer3d_type - class(*), allocatable :: buffer(:,:,:) !< 3D numeric data array - class(*), allocatable :: counter(:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_3d - procedure :: initialize_buffer => initialize_buffer_3d - procedure :: add_to_buffer => add_to_buffer_3d - procedure :: get_buffer => get_3d -end type outputBuffer3d_type - -!> 4D buffer type to extend fmsDiagBuffer_class -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer4d_type - class(*), allocatable :: buffer(:,:,:,:) !< 4D numeric data array - class(*), allocatable :: counter(:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_4d - procedure :: initialize_buffer => initialize_buffer_4d - procedure :: add_to_buffer => add_to_buffer_4d - procedure :: get_buffer => get_4d -end type outputBuffer4d_type + procedure :: allocate_buffer + procedure :: initialize_buffer + procedure :: get_buffer + procedure :: flush_buffer -!> 5D buffer type to extend fmsDiagBuffer_class -type, extends(fmsDiagOutputBuffer_class) :: outputBuffer5d_type - class(*), allocatable :: buffer(:,:,:,:,:) !< 5D numeric data array - class(*), allocatable :: counter(:,:,:,:,:) !< (x,y,z, time-of-day) used in the time averaging functions - contains - procedure :: allocate_buffer => allocate_buffer_5d - procedure :: initialize_buffer => initialize_buffer_5d - procedure :: add_to_buffer => add_to_buffer_5d - procedure :: get_buffer => get_5d -end type outputBuffer5d_type +end type fmsDiagOutputBuffer_type ! public types -public :: outputBuffer0d_type -public :: outputBuffer1d_type -public :: outputBuffer2d_type -public :: outputBuffer3d_type -public :: outputBuffer4d_type -public :: outputBuffer5d_type -public :: fmsDiagOutputBuffer_class -public :: fmsDiagOutputBufferContainer_type +public :: fmsDiagOutputBuffer_type ! public routines public :: fms_diag_output_buffer_init -public :: fms_diag_output_buffer_create_container contains @@ -169,963 +84,159 @@ module fms_diag_output_buffer_mod !> Initializes a list of diag buffers !> @returns true if allocation is successfull logical function fms_diag_output_buffer_init(buffobjs, buff_list_size) - type(fmsDiagOutputBufferContainer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types - !! to allocate - integer, intent(in) :: buff_list_size !< size of buffer array to allocate + type(fmsDiagOutputBuffer_type), allocatable, intent(out) :: buffobjs(:) !< an array of buffer container types + !! to allocate + integer, intent(in) :: buff_list_size !< size of buffer array to allocate + if (allocated(buffobjs)) call mpp_error(FATAL,'fms_diag_buffer_init: passed in buffobjs array is already allocated') allocate(buffobjs(buff_list_size)) fms_diag_output_buffer_init = allocated(buffobjs) end function fms_diag_output_buffer_init -!> Creates a container type encapsulating a new buffer object for the given dimensions. -!! The buffer object will still need to be allocated to a type via allocate_buffer() before use. -!> @result A fmsDiagBufferContainer_type that holds a bufferNd_type, where N is buff_dims -subroutine fms_diag_output_buffer_create_container(buff_dims, buffer_obj) - integer, intent(in) :: buff_dims !< dimensions - type(fmsDiagOutputBufferContainer_type), intent(inout) :: buffer_obj - - character(len=5) :: dim_output !< string to output buff_dims on error - - select case (buff_dims) - case (0) - allocate(outputBuffer0d_type :: buffer_obj%diag_buffer_obj) - case (1) - allocate(outputBuffer1d_type :: buffer_obj%diag_buffer_obj) - case (2) - allocate(outputBuffer2d_type :: buffer_obj%diag_buffer_obj) - case (3) - allocate(outputBuffer3d_type :: buffer_obj%diag_buffer_obj) - case (4) - allocate(outputBuffer4d_type :: buffer_obj%diag_buffer_obj) - case (5) - allocate(outputBuffer5d_type :: buffer_obj%diag_buffer_obj) - case default - write( dim_output, *) buff_dims - dim_output = adjustl(dim_output) - call mpp_error(FATAL, 'fms_diag_buffer_create_container: invalid number of dimensions given:' // dim_output //& - '. Must be 0-5') - end select -end subroutine fms_diag_output_buffer_create_container - !!--------generic routines for any fmsDiagBuffer_class objects -!> Setter for buffer_id for any buffer objects -subroutine set_buffer_id(this, id) - class(fmsDiagOutputBuffer_class), intent(inout) :: this !< buffer object to set id for - integer, intent(in) :: id !< positive integer id to set - if (.not.allocated(this%buffer_id) ) allocate(this%buffer_id) - this%buffer_id = id -end subroutine set_buffer_id - -!> Remaps 0-5d data buffer from the given object onto a 5d array pointer. -!> @returns a 5D remapped buffer, with 1:1 for any added dimensions. -function remap_buffer(buffobj, field_name, has_diurnal_axis) - class(fmsDiagOutputBuffer_class), target, intent(inout) :: buffobj !< any dimension buffer object - class(*), pointer :: remap_buffer(:,:,:,:,:) - character(len=*), intent(in) :: field_name !< name of field for error output - logical, intent(in) :: has_diurnal_axis !< true if the buffer has diurnal axis - - ! get num dimensions from type extension - select type (buffobj) - type is (outputBuffer0d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer - type is (outputBuffer1d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:1) => buffobj%buffer(1:size(buffobj%buffer,1)) - type is (outputBuffer2d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - if (has_diurnal_axis) then - remap_buffer(1:size(buffobj%buffer,1), 1:1, 1:1, 1:1, 1:size(buffobj%buffer,2)) => buffobj%buffer(:,:) - else - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, 1:1) => buffobj%buffer(:,:) - end if - type is (outputBuffer3d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - if (has_diurnal_axis) then - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:1, 1:1, & - 1:size(buffobj%buffer,3)) => buffobj%buffer(:,:,:) - else - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), & - 1:size(buffobj%buffer,3), 1:1, 1:1) => buffobj%buffer(:,:,:) - end if - type is (outputBuffer4d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - if (has_diurnal_axis) then - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), & - 1:1, 1:size(buffobj%buffer,4)) => buffobj%buffer(:,:,:,:) - else - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), & - 1:size(buffobj%buffer,4), 1:1) => buffobj%buffer(:,:,:,:) - end if - type is (outputBuffer5d_type) - if (.not. allocated(buffobj%buffer)) call mpp_error(FATAL, "remap_buffer: buffer data not yet allocated" // & - "for field:" // field_name) - remap_buffer(1:size(buffobj%buffer,1), 1:size(buffobj%buffer,2), 1:size(buffobj%buffer,3), & - 1:size(buffobj%buffer,4), 1:size(buffobj%buffer,5)) => buffobj%buffer(:,:,:,:,:) - class default - call mpp_error( FATAL, 'remap_buffer_pointer: invalid buffer type for remapping') - end select - -end function remap_buffer - -!> Deallocates data fields from a buffer object. -subroutine flush_buffer(this) - class(fmsDiagOutputBuffer_class), intent(inout) :: this !< any buffer object - select type (this) - type is (outputBuffer0d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - type is (outputBuffer1d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - type is (outputBuffer2d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - type is (outputBuffer3d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - type is (outputBuffer4d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - type is (outputBuffer5d_type) - if (allocated(this%buffer)) deallocate(this%buffer) - if (allocated(this%counter)) deallocate(this%counter) - end select - if (allocated(this%buffer_id)) deallocate(this%buffer_id) - if (allocated(this%count_0d)) deallocate(this%count_0d) - if (allocated(this%num_elements)) deallocate(this%num_elements) - if (allocated(this%buffer_dims)) deallocate(this%buffer_dims) -end subroutine flush_buffer - -!! -----------Type-specific routines for buffer0-5d - -!> Allocates scalar buffer data to the given buff_type. -subroutine allocate_buffer_0d(this, buff_type, field_name, diurnal_samples) - class(outputBuffer0d_type), intent(inout), target :: this !< scalar buffer object - class(*),intent(in) :: buff_type !< allocates to the given type, value does not matter - character(len=*), intent(in) :: field_name !< field name for error output - integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_0d: buffer already allocated for field:"// & - field_name) - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer(1)) - allocate(integer(kind=i4_kind) :: this%counter(1)) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer(1)) - allocate(integer(kind=i8_kind) :: this%counter(1)) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer(1)) - allocate(real(kind=r4_kind) :: this%counter(1)) - allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer(1)) - allocate(real(kind=r8_kind) :: this%counter(1)) - allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_0d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & - "for field:" // field_name, & - FATAL) - end select - - allocate(this%num_elements(n_samples)) - allocate(this%buffer_dims(1)) - this%num_elements = 0 - this%buffer_dims(1) = 1 - -end subroutine allocate_buffer_0d - -!> Allocates 1D buffer data to given buff_type. -subroutine allocate_buffer_1d(this, buff_type, buff_size, field_name, diurnal_samples) - class(outputBuffer1d_type), intent(inout), target :: this !< scalar buffer object - class(*),intent(in) :: buff_type !< allocates to the type of buff_type - integer, intent(in) :: buff_size !< dimension bounds - character(len=*), intent(in) :: field_name !< field name for error output - integer, intent(in), optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_1d: buffer already allocated for field:" // & - field_name) - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer(buff_size)) - allocate(integer(kind=i4_kind) :: this%counter(buff_size)) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer(buff_size)) - allocate(integer(kind=i8_kind) :: this%counter(buff_size)) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer(buff_size)) - allocate(real(kind=r4_kind) :: this%count_0d(buff_size)) - allocate(real(kind=r4_kind) :: this%counter(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer(buff_size)) - allocate(real(kind=r8_kind) :: this%count_0d(buff_size)) - allocate(real(kind=r8_kind) :: this%counter(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_1d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4 " // & - "for field:" // field_name, & - FATAL) - end select - - allocate(this%num_elements(n_samples)) - allocate(this%buffer_dims(1)) - this%num_elements = 0 - this%count_0d = 0 - this%buffer_dims(1) = buff_size - -end subroutine allocate_buffer_1d - -!> Allocates a 2D buffer to given buff_type. -subroutine allocate_buffer_2d(this, buff_type, buff_sizes, field_name, diurnal_samples) - class(outputBuffer2d_type), intent(inout), target :: this !< 2D buffer object - class(*),intent(in) :: buff_type !< allocates to the type of buff_type - integer, intent(in) :: buff_sizes(2) !< dimension sizes - integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - character(len=*), intent(in) :: field_name !< field name for error output - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_2d: buffer already allocated for field: " // & - field_name) - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2))) - allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1), buff_sizes(2))) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2))) - allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1), buff_sizes(2))) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1), buff_sizes(2))) - allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1), buff_sizes(2))) - allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1), buff_sizes(2))) - allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1), buff_sizes(2))) - allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_1d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & - "for field:" // field_name, & - FATAL) - end select - allocate(this%num_elements(n_samples)) - allocate(this%buffer_dims(2)) - this%num_elements = 0 - this%buffer_dims(1) = buff_sizes(1) - this%buffer_dims(2) = buff_sizes(2) - -end subroutine allocate_buffer_2d - -!> Allocates a 3D buffer to given buff_type. -subroutine allocate_buffer_3d(this, buff_type, buff_sizes, field_name, diurnal_samples) - class(outputBuffer3d_type), intent(inout), target :: this !< 3D buffer object - class(*),intent(in) :: buff_type !< allocates to the type of buff_type - integer, intent(in) :: buff_sizes(3) !< dimension sizes - integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - character(len=*), intent(in) :: field_name !< field name for error output - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_3d: buffer already allocated for field" // & - field_name) - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer( buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(real(kind=r8_kind) :: this%counter( buff_sizes(1),buff_sizes(2), buff_sizes(3))) - allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_3d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & - "for field:" // field_name, FATAL) - end select - - allocate(this%num_elements(n_samples)) - this%num_elements = 0 - this%count_0d = 0 - allocate(this%buffer_dims(3)) - this%buffer_dims(1) = buff_sizes(1) - this%buffer_dims(2) = buff_sizes(2) - this%buffer_dims(3) = buff_sizes(3) - -end subroutine allocate_buffer_3d - -!> Allocates a 4D buffer to given buff_type. -subroutine allocate_buffer_4d(this, buff_type, buff_sizes, field_name, diurnal_samples) - class(outputBuffer4d_type), intent(inout), target :: this !< 4D buffer object - class(*),intent(in) :: buff_type !< allocates to the type of buff_type - integer, intent(in) :: buff_sizes(4) !< dimension buff_sizes - character(len=*), intent(in) :: field_name !< field name for error output - integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_4d: buffer already allocated for field:" // & - field_name) - - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4))) - allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_4d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & - "for field:" // field_name, FATAL) - end select - - allocate(this%num_elements(n_samples)) - this%num_elements = 0 - this%count_0d = 0 - allocate(this%buffer_dims(4)) - this%buffer_dims(1) = buff_sizes(1) - this%buffer_dims(2) = buff_sizes(2) - this%buffer_dims(3) = buff_sizes(3) - this%buffer_dims(4) = buff_sizes(4) - -end subroutine allocate_buffer_4d - -!> Allocates a 5D buffer to given buff_type. -subroutine allocate_buffer_5d(this, buff_type, buff_sizes, field_name, diurnal_samples) - class(outputBuffer5d_type), intent(inout), target :: this !< 5D buffer object - class(*),intent(in) :: buff_type !< allocates to the type of buff_type - integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes - character(len=*), intent(in) :: field_name !< field name for error output - integer, intent(in),optional :: diurnal_samples !< number of diurnal samples, passed in from diag_yaml - integer :: n_samples !< number of diurnal samples, defaults to 1 - - if(present(diurnal_samples)) then - n_samples = diurnal_samples - else - n_samples = 1 - endif - - if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer_5d: buffer already allocated for field:" // & - field_name) - select type (buff_type) - type is (integer(kind=i4_kind)) - allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) - this%counter = 0_i4_kind - this%count_0d = 0_i4_kind - this%buffer_type = i4 - type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) - this%counter = 0_i8_kind - this%count_0d = 0_i8_kind - this%buffer_type = i8 - type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r4_kind - this%count_0d = 0.0_r4_kind - this%buffer_type = r4 - type is (real(kind=r8_kind)) - allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & - & buff_sizes(5))) - allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) - this%counter = 0.0_r8_kind - this%count_0d = 0.0_r8_kind - this%buffer_type = r8 - class default - call mpp_error("allocate_buffer_5d", & - "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & - "for field:" // field_name, FATAL) - end select - allocate(this%num_elements(n_samples)) - this%num_elements = 0 - this%count_0d = 0 - allocate(this%buffer_dims(5)) - this%buffer_dims(1) = buff_sizes(1) - this%buffer_dims(2) = buff_sizes(2) - this%buffer_dims(3) = buff_sizes(3) - this%buffer_dims(4) = buff_sizes(4) - this%buffer_dims(5) = buff_sizes(5) -end subroutine allocate_buffer_5d - -!> Get routine for scalar buffers. -!! Sets the buff_out argument to the integer or real value currently stored in the buffer. -subroutine get_0d (this, buff_out, field_name) - class(outputBuffer0d_type), intent(in) :: this !< 0d allocated buffer object - class(*), allocatable, intent(out) :: buff_out !< output of copied buffer data - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' & - & // field_name) - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out) - buff_out = buff(1) - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out) - buff_out = buff(1) - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out) - buff_out = buff(1) - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out) - buff_out = buff(1) - class default - call mpp_error(FATAL, "get_0d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - field_name) - end select -end subroutine - -!> Get routine for 1D buffers. -!! Sets the buff_out argument to the integer or real array currently stored in the buffer. -subroutine get_1d (this, buff_out, field_name) - class(outputBuffer1d_type), intent(in) :: this !< 1d allocated buffer object - class(*), allocatable, intent(out) :: buff_out(:) !< output of copied buffer data - !! must be the same size as the allocated buffer - integer(i4_kind) :: buff_size !< size for allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_0d(get_buffer): buffer not yet allocated for field:' & - & // field_name) - buff_size = size(this%buffer,1) - - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out(buff_size)) - buff_out = buff - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out(buff_size)) - buff_out = buff - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out(buff_size)) - buff_out = buff - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out(buff_size)) - buff_out = buff - class default - call mpp_error(FATAL, "get_1d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - "field name: "// field_name) - end select -end subroutine - -!> Get routine for 2D buffers. -!! Sets the buff_out argument to the integer or real array currently stored in the buffer. -subroutine get_2d (this, buff_out, field_name) - class(outputBuffer2d_type), intent(in) :: this !< 2d allocated buffer object - class(*), allocatable, intent(out) :: buff_out(:,:) !< output of copied buffer data - !! must be the same size as the allocated buffer - integer(i4_kind) :: buff_size(2) !< sizes for allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_2d(get_buffer): buffer not yet allocated for field:' & - & // field_name) - buff_size(1) = size(this%buffer,1) - buff_size(2) = size(this%buffer,2) - - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2))) - buff_out = buff - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2))) - buff_out = buff - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2))) - buff_out = buff - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2))) - buff_out = buff - class default - call mpp_error(FATAL, "get_2d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - "field name: "// field_name) - - end select -end subroutine - -!> Get routine for 3D buffers. -!! Sets the buff_out argument to the integer or real array currently stored in the buffer. -subroutine get_3d (this, buff_out, field_name) - class(outputBuffer3d_type), intent(in) :: this !< 3d allocated buffer object - class(*), allocatable, intent(out) :: buff_out(:,:,:) !< output of copied buffer data - !! must be the same size as the allocated buffer - integer(i4_kind) :: buff_size(3)!< sizes for allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_3d(get_buffer): buffer not yet allocated for field:' & - & // field_name) - buff_size(1) = size(this%buffer,1) - buff_size(2) = size(this%buffer,2) - buff_size(3) = size(this%buffer,3) - - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3))) - buff_out = buff - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3))) - buff_out = buff - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3))) - buff_out = buff - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3))) - buff_out = buff - class default - call mpp_error(FATAL, "get_3d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - "field name: "// field_name) - end select -end subroutine - -!> Get routine for 4D buffers. -!! Sets the buff_out argument to the integer or real array currently stored in the buffer. -subroutine get_4d (this, buff_out, field_name) - class(outputBuffer4d_type), intent(in) :: this !< 4d allocated buffer object - class(*), allocatable, intent(out) :: buff_out(:,:,:,:) !< output of copied buffer data - !! must be the same size as the allocated buffer - integer(i4_kind) :: buff_size(4)!< sizes for allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_4d(get_buffer): buffer not yet allocated for field:' & - & // field_name) - buff_size(1) = size(this%buffer,1) - buff_size(2) = size(this%buffer,2) - buff_size(3) = size(this%buffer,3) - buff_size(4) = size(this%buffer,4) - - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4))) - buff_out = buff - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4))) - buff_out = buff - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4))) - buff_out = buff - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4))) - buff_out = buff - class default - call mpp_error(FATAL, "get_4d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - "field name: "// field_name) - end select -end subroutine - -!> Get routine for 5D buffers. -!! Sets the buff_out argument to the integer or real array currently stored in the buffer. -subroutine get_5d (this, buff_out, field_name) - class(outputBuffer5d_type), intent(in) :: this !< 5d allocated buffer object - class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data - !! must be the same size as the allocated buffer - integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_5d: buffer not yet allocated for field:' & - & // field_name) - buff_size(1) = size(this%buffer,1) - buff_size(2) = size(this%buffer,2) - buff_size(3) = size(this%buffer,3) - buff_size(4) = size(this%buffer,4) - buff_size(5) = size(this%buffer,5) - - select type (buff=>this%buffer) - type is (real(r4_kind)) - allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) - buff_out = buff - type is (real(r8_kind)) - allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) - buff_out = buff - type is (integer(i4_kind)) - allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) - buff_out = buff - type is (integer(i8_kind)) - allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) - buff_out = buff - class default - call mpp_error(FATAL, "get_5d: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)." // & - "field name: "// field_name) - end select -end subroutine - -!> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_0d (this, fillval, field_name) - class(outputBuffer0d_type), intent(inout) :: this !< scalar buffer object - class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_0d: field:'// field_name // & - 'buffer not yet allocated, allocate_buffer() must be called on this object first.') - select type(buff => this%buffer) - type is(real(r8_kind)) - select type(fillval) - type is(real(r8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r8_kind)' // & - ' for field' // field_name ) - end select - type is(real(r4_kind)) - select type(fillval) - type is(real(r4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(r4_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i8_kind)) - select type(fillval) - type is(integer(i8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i8_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i4_kind)) - select type(fillval) - type is(integer(i4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_0d: fillval does not match up with allocated buffer type(i4_kind)' // & - ' for field' // field_name ) - end select - class default - call mpp_error(FATAL, 'initialize buffer_0d: buffer allocated to invalid data type, this shouldnt happen') - end select - -end subroutine initialize_buffer_0d - -!> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_1d (this, fillval, field_name) - class(outputBuffer1d_type), intent(inout) :: this !< 1D buffer object - class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_1d: field:'// field_name // & - 'buffer not yet allocated, allocate_buffer() must be called on this object first.') - ! have to check fill value and buffer types match - select type(buff => this%buffer) - type is(real(r8_kind)) - select type(fillval) - type is(real(r8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r8_kind)' // & - ' for field' // field_name ) - end select - type is(real(r4_kind)) - select type(fillval) - type is(real(r4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(r4_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i8_kind)) - select type(fillval) - type is(integer(i8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i8_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i4_kind)) - select type(fillval) - type is(integer(i4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_1d: fillval does not match up with allocated buffer type(i4_kind)' // & - ' for field' // field_name ) - end select - class default - call mpp_error(FATAL, 'initialize buffer_1d: buffer allocated to invalid data type, this shouldnt happen') - end select - -end subroutine initialize_buffer_1d - -!> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_2d (this, fillval, field_name) - class(outputBuffer2d_type), intent(inout) :: this !< 2D buffer object - class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output - - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_2d: field:'// field_name // & - 'buffer not yet allocated, allocate_buffer() must be called on this object first.') - ! have to check fill value and buffer types match - select type(buff => this%buffer) - type is(real(r8_kind)) - select type(fillval) - type is(real(r8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r8_kind)' // & - ' for field' // field_name ) - end select - type is(real(r4_kind)) - select type(fillval) - type is(real(r4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(r4_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i8_kind)) - select type(fillval) - type is(integer(i8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i8_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i4_kind)) - select type(fillval) - type is(integer(i4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_2d: fillval does not match up with allocated buffer type(i4_kind)' // & - ' for field' // field_name ) - end select - class default - call mpp_error(FATAL, 'initialize buffer_2d: buffer allocated to invalid data type, this shouldnt happen') - end select - -end subroutine initialize_buffer_2d +!> Setter for buffer_id for any buffer objects +subroutine set_buffer_id(this, id) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< buffer object to set id for + integer, intent(in) :: id !< positive integer id to set -!> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_3d (this, fillval, field_name) - class(outputBuffer3d_type), intent(inout) :: this !< 3D buffer object - class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output + this%buffer_id = id +end subroutine set_buffer_id - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_3d: field:'// field_name // & - 'buffer not yet allocated, allocate_buffer() must be called on this object first.') - ! have to check fill value and buffer types match - select type(buff => this%buffer) - type is(real(r8_kind)) - select type(fillval) - type is(real(r8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r8_kind)' // & - ' for field' // field_name ) - end select - type is(real(r4_kind)) - select type(fillval) - type is(real(r4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(r4_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i8_kind)) - select type(fillval) - type is(integer(i8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i8_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i4_kind)) - select type(fillval) - type is(integer(i4_kind)) - buff = fillval +!> Deallocates data fields from a buffer object. +subroutine flush_buffer(this) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< any buffer object + + this%buffer_id = diag_null + this%buffer_type = diag_null + this%ndim = diag_null + this%field_id = diag_null + this%yaml_id = diag_null + if (allocated(this%buffer)) deallocate(this%buffer) + if (allocated(this%buffer_dims)) deallocate(this%buffer_dims) + if (allocated(this%counter)) deallocate(this%counter) + if (allocated(this%num_elements)) deallocate(this%num_elements) + if (allocated(this%count_0d)) deallocate(this%count_0d) + if (allocated(this%axis_ids)) deallocate(this%axis_ids) +end subroutine flush_buffer + +!> Allocates a 5D buffer to given buff_type. +subroutine allocate_buffer(this, buff_type, ndim, buff_sizes, field_name, diurnal_samples) + class(fmsDiagOutputBuffer_type), intent(inout), target :: this !< 5D buffer object + class(*), intent(in) :: buff_type !< allocates to the type of buff_type + integer, intent(in) :: ndim !< Number of dimension + integer, intent(in) :: buff_sizes(5) !< dimension buff_sizes + character(len=*), intent(in) :: field_name !< field name for error output + integer, optional, intent(in) :: diurnal_samples !< number of diurnal samples + + integer :: n_samples !< number of diurnal samples, defaults to 1 + + if(present(diurnal_samples)) then + n_samples = diurnal_samples + else + n_samples = 1 + endif + + this%ndim =ndim + if(allocated(this%buffer)) call mpp_error(FATAL, "allocate_buffer: buffer already allocated for field:" // & + field_name) + select type (buff_type) + type is (integer(kind=i4_kind)) + allocate(integer(kind=i4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(integer(kind=i4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(integer(kind=i4_kind) :: this%count_0d(n_samples)) + this%counter = 0_i4_kind + this%count_0d = 0_i4_kind + this%buffer_type = i4 + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(integer(kind=i8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(integer(kind=i8_kind) :: this%count_0d(n_samples)) + this%counter = 0_i8_kind + this%count_0d = 0_i8_kind + this%buffer_type = i8 + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(real(kind=r4_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(real(kind=r4_kind) :: this%count_0d(n_samples)) + this%counter = 0.0_r4_kind + this%count_0d = 0.0_r4_kind + this%buffer_type = r4 + type is (real(kind=r8_kind)) + allocate(real(kind=r8_kind) :: this%buffer(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(real(kind=r8_kind) :: this%counter(buff_sizes(1),buff_sizes(2),buff_sizes(3),buff_sizes(4), & + & buff_sizes(5))) + allocate(real(kind=r8_kind) :: this%count_0d(n_samples)) + this%counter = 0.0_r8_kind + this%count_0d = 0.0_r8_kind + this%buffer_type = r8 class default - call mpp_error(FATAL, 'initialize_buffer_3d: fillval does not match up with allocated buffer type(i4_kind)' // & - ' for field' // field_name ) - end select - class default - call mpp_error(FATAL, 'initialize buffer_3d: buffer allocated to invalid data type, this shouldnt happen') + call mpp_error("allocate_buffer", & + "The buff_type value passed to allocate a buffer is not a r8, r4, i8, or i4" // & + "for field:" // field_name, FATAL) end select + allocate(this%num_elements(n_samples)) + this%num_elements = 0 + this%count_0d = 0 + allocate(this%buffer_dims(5)) + this%buffer_dims(1) = buff_sizes(1) + this%buffer_dims(2) = buff_sizes(2) + this%buffer_dims(3) = buff_sizes(3) + this%buffer_dims(4) = buff_sizes(4) + this%buffer_dims(5) = buff_sizes(5) +end subroutine allocate_buffer -end subroutine initialize_buffer_3d +!> Get routine for 5D buffers. +!! Sets the buff_out argument to the integer or real array currently stored in the buffer. +subroutine get_buffer (this, buff_out, field_name) + class(fmsDiagOutputBuffer_type), intent(in) :: this !< 5d allocated buffer object + class(*), allocatable, intent(out) :: buff_out(:,:,:,:,:) !< output of copied buffer data + !! must be the same size as the allocated buffer + character(len=*), intent(in) :: field_name !< field name for error output -!> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_4d (this, fillval, field_name) - class(outputBuffer4d_type), intent(inout) :: this !< allocated 4D buffer object - class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output + integer(i4_kind) :: buff_size(5)!< sizes for allocated buffer - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_4d: field:'// field_name // & - 'buffer not yet allocated, allocate_buffer() must be called on this object first.') - ! have to check fill value and buffer types match - select type(buff => this%buffer) - type is(real(r8_kind)) - select type(fillval) - type is(real(r8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r8_kind)' // & - ' for field' // field_name ) - end select - type is(real(r4_kind)) - select type(fillval) - type is(real(r4_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(r4_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i8_kind)) - select type(fillval) - type is(integer(i8_kind)) - buff = fillval - class default - call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i8_kind)' // & - ' for field' // field_name ) - end select - type is(integer(i4_kind)) - select type(fillval) - type is(integer(i4_kind)) - buff = fillval + if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'get_buffer: buffer not yet allocated for field:' & + & // field_name) + buff_size(1) = size(this%buffer,1) + buff_size(2) = size(this%buffer,2) + buff_size(3) = size(this%buffer,3) + buff_size(4) = size(this%buffer,4) + buff_size(5) = size(this%buffer,5) + + select type (buff=>this%buffer) + type is (real(r4_kind)) + allocate(real(r4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (real(r8_kind)) + allocate(real(r8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (integer(i4_kind)) + allocate(integer(i4_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff + type is (integer(i8_kind)) + allocate(integer(i8_kind) :: buff_out(buff_size(1), buff_size(2), buff_size(3), buff_size(4), buff_size(5))) + buff_out = buff class default - call mpp_error(FATAL, 'initialize_buffer_4d: fillval does not match up with allocated buffer type(i4_kind)' // & - ' for field' // field_name ) - end select - class default - call mpp_error(FATAL, 'initialize buffer_4d: buffer allocated to invalid data type, this shouldnt happen') + call mpp_error(FATAL, "get_buffer: buffer allocated to invalid type(must be integer or real, kind size 4 or 8)."& + //"field name: "// field_name) end select - -end subroutine initialize_buffer_4d +end subroutine !> @brief Initializes a buffer to a given fill value. -subroutine initialize_buffer_5d (this, fillval, field_name) - class(outputBuffer5d_type), intent(inout) :: this !< allocated 5D buffer object - class(*), intent(in) :: fillval!< fill value, must be same type as the allocated buffer in this - character(len=*), intent(in) :: field_name !< field name for error output +subroutine initialize_buffer (this, fillval, field_name) + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< allocated 5D buffer object + class(*), intent(in) :: fillval !< fill value, must be same type as the allocated buffer + character(len=*), intent(in) :: field_name !< field name for error output - if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer_5d: field:'// field_name // & + if(.not. allocated(this%buffer)) call mpp_error(FATAL, 'initialize_buffer: field:'// field_name // & 'buffer not yet allocated, allocate_buffer() must be called on this object first.') ! have to check fill value and buffer types match select type(buff => this%buffer) @@ -1134,7 +245,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name) type is(real(r8_kind)) buff = fillval class default - call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r8_kind)' // & + call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r8_kind)' // & ' for field' // field_name ) end select type is(real(r4_kind)) @@ -1142,7 +253,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name) type is(real(r4_kind)) buff = fillval class default - call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(r4_kind)' // & + call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(r4_kind)' // & ' for field' // field_name ) end select type is(integer(i8_kind)) @@ -1150,7 +261,7 @@ subroutine initialize_buffer_5d (this, fillval, field_name) type is(integer(i8_kind)) buff = fillval class default - call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i8_kind)' // & + call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i8_kind)' // & ' for field' // field_name ) end select type is(integer(i4_kind)) @@ -1158,294 +269,19 @@ subroutine initialize_buffer_5d (this, fillval, field_name) type is(integer(i4_kind)) buff = fillval class default - call mpp_error(FATAL, 'initialize_buffer_5d: fillval does not match up with allocated buffer type(i4_kind)' // & + call mpp_error(FATAL, 'initialize_buffer: fillval does not match up with allocated buffer type(i4_kind)' // & ' for field' // field_name ) end select class default call mpp_error(FATAL, 'initialize buffer_5d: buffer allocated to invalid data type, this shouldnt happen') end select -end subroutine initialize_buffer_5d - -!> @brief Add values to 0d buffer. -!! This will just call the init routine since there's only one value. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_0d(this, input_data, field_name) - class(outputBuffer0d_type), intent(inout) :: this !< allocated scalar buffer object - class(*), intent(in) :: input_data !< data to copy into buffer - character(len=*), intent(in) :: field_name !< field name for error output - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_0d: buffer not yet allocated for field:'// & - field_name) - call this%initialize_buffer(input_data, field_name) -end subroutine add_to_buffer_0d - -!> @brief Copy values ( from 1 to size(input_data)) into a 1d buffer object. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_1d(this, input_data, field_name) - class(outputBuffer1d_type), intent(inout) :: this !< allocated 1d buffer object - class(*), intent(in) :: input_data(:) !< data to copy into the buffer - integer :: n !< number of elements in input data - logical :: type_error !< set to true if mismatch between input_data and allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - type_error = .false. - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_1d: buffer not yet allocated for field:' // & - field_name) - n = SIZE(input_data) - if( n .gt. SIZE(this%buffer)) call mpp_error( FATAL,"add_to_buffer_1d: input data larger than allocated buffer " // & - "for field: "// field_name) - ! have to check both types for assignment - select type( buffer => this%buffer ) - type is(integer(i4_kind)) - select type(input_data) - type is(integer(i4_kind)) - buffer(1:n) = input_data(1:n) - class default - type_error = .true. - end select - type is(integer(i8_kind)) - select type(input_data) - type is(integer(i8_kind)) - buffer(1:n) = input_data(1:n) - class default - type_error = .true. - end select - type is(real(r4_kind)) - select type(input_data) - type is(real(r4_kind)) - buffer(1:n) = input_data(1:n) - class default - type_error = .true. - end select - type is(real(r8_kind)) - select type(input_data) - type is(real(r8_kind)) - buffer(1:n) = input_data(1:n) - class default - type_error = .true. - end select - end select - if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'// & - ' for field:' // field_name) -end subroutine add_to_buffer_1d - -!> @brief Copy values ( from 1 to size(input_data)) into a 2d buffer object. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_2d(this, input_data, field_name) - class(outputBuffer2d_type), intent(inout) :: this !< allocated 2d buffer object - class(*), intent(in) :: input_data(:,:) !< 2d data array to copy into buffer - integer :: n1, n2 !< number of elements per dimension - logical :: type_error !< set to true if mismatch between input_data and allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - type_error = .false. - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_2d: buffer not yet allocated for field:' // & - field_name) - n1 = SIZE(input_data, 1) - n2 = SIZE(input_data, 2) - if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2)) then - call mpp_error( FATAL,"add_to_buffer_2d: input data larger than allocated buffer") - endif - ! have to check both types for assignment - select type( buffer => this%buffer ) - type is(integer(i4_kind)) - select type(input_data) - type is(integer(i4_kind)) - buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2) - class default - type_error = .true. - end select - type is(integer(i8_kind)) - select type(input_data) - type is(integer(i8_kind)) - buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2) - class default - type_error = .true. - end select - type is(real(r4_kind)) - select type(input_data) - type is(real(r4_kind)) - buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2) - class default - type_error = .true. - end select - type is(real(r8_kind)) - select type(input_data) - type is(real(r8_kind)) - buffer(1:n1, 1:n2) = input_data(1:n1, 1:n2) - class default - type_error = .true. - end select - end select - if( type_error ) call mpp_error (FATAL,'add_to_buffer_1d: mismatch between allocated buffer and input data types'//& - ' for field:'// field_name) -end subroutine add_to_buffer_2d - -!> @brief Copy values ( from 1 to size(input_data)) into a 3d buffer object. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_3d(this, input_data, field_name) - class(outputBuffer3d_type), intent(inout) :: this !< allocated 3d buffer object - class(*), intent(in) :: input_data(:,:,:)!< 3d data array to copy into buffer - integer :: n1, n2, n3 !< number of elements per dimension - logical :: type_error !< set to true if mismatch between input_data and allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - type_error = .false. - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_3d: buffer not yet allocated for field:'//& - field_name) - n1 = SIZE(input_data, 1) - n2 = SIZE(input_data, 2) - n3 = SIZE(input_data, 3) - if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. & - n3 .gt. SIZE(this%buffer, 3)) then - call mpp_error( FATAL,"add_to_buffer_3d: input data larger than allocated buffer for field:"//field_name) - endif - ! have to check both types for assignment - select type( buffer => this%buffer ) - type is(integer(i4_kind)) - select type(input_data) - type is(integer(i4_kind)) - buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3) - class default - type_error = .true. - end select - type is(integer(i8_kind)) - select type(input_data) - type is(integer(i8_kind)) - buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3) - class default - type_error = .true. - end select - type is(real(r4_kind)) - select type(input_data) - type is(real(r4_kind)) - buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3) - class default - type_error = .true. - end select - type is(real(r8_kind)) - select type(input_data) - type is(real(r8_kind)) - buffer(1:n1, 1:n2, 1:n3) = input_data(1:n1, 1:n2, 1:n3) - class default - type_error = .true. - end select - end select - if( type_error ) call mpp_error (FATAL,'add_to_buffer_3d: mismatch between allocated buffer and input data types'//& - ' for field:'//field_name) -end subroutine add_to_buffer_3d - -!> @brief Copy values ( from 1 to size(input_data)) into a 4d buffer object. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_4d(this, input_data, field_name) - class(outputBuffer4d_type), intent(inout) :: this !< allocated 4d buffer object - class(*), intent(in) :: input_data(:,:,:,:) !< 4d data to copy into buffer - integer :: n1, n2, n3, n4!< number of elements per dimension - logical :: type_error !< set to true if mismatch between input_data and allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - type_error = .false. - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_4d: buffer not yet allocated for field:'// & - field_name) - n1 = SIZE(input_data, 1) - n2 = SIZE(input_data, 2) - n3 = SIZE(input_data, 3) - n4 = SIZE(input_data, 4) - if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. & - n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4)) then - call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name) - endif - ! have to check both types for assignment - select type( buffer => this%buffer ) - type is(integer(i4_kind)) - select type(input_data) - type is(integer(i4_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4) - class default - type_error = .true. - end select - type is(integer(i8_kind)) - select type(input_data) - type is(integer(i8_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4) - class default - type_error = .true. - end select - type is(real(r4_kind)) - select type(input_data) - type is(real(r4_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4) - class default - type_error = .true. - end select - type is(real(r8_kind)) - select type(input_data) - type is(real(r8_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4) = input_data(1:n1, 1:n2, 1:n3, 1:n4) - class default - type_error = .true. - end select - end select - if( type_error ) call mpp_error (FATAL,'add_to_buffer_4d: mismatch between allocated buffer and input data types'// & - ' for field:' //field_name) -end subroutine add_to_buffer_4d - -!> @brief Copy values (from 1 to size(input_data)) into a 5d buffer object. -!! @note input_data must match allocated type of buffer object. -subroutine add_to_buffer_5d(this, input_data, field_name) - class(outputBuffer5d_type), intent(inout) :: this !< allocated 5d buffer object - class(*), intent(in) :: input_data(:,:,:,:,:) !< 5d data to copy into buffer - integer :: n1, n2, n3, n4, n5 !< number of elements per dimension - logical :: type_error !< set to true if mismatch between input_data and allocated buffer - character(len=*), intent(in) :: field_name !< field name for error output - type_error = .false. - if( .not. allocated(this%buffer)) call mpp_error (FATAL, 'add_to_buffer_5d: buffer not yet allocated for field:'// & - field_name) - n1 = SIZE(input_data, 1) - n2 = SIZE(input_data, 2) - n3 = SIZE(input_data, 3) - n4 = SIZE(input_data, 4) - n5 = SIZE(input_data, 5) - if( n1 .gt. SIZE(this%buffer, 1) .or. n2 .gt. SIZE(this%buffer, 2) .or. & - n3 .gt. SIZE(this%buffer, 3) .or. n4 .gt. SIZE(this%buffer, 4) .or. & - n5 .gt. SIZE(this%buffer, 5)) then - call mpp_error( FATAL,"add_to_buffer_4d: input data larger than allocated buffer for field:"//field_name) - endif - ! have to check both types for assignment - select type( buffer => this%buffer ) - type is(integer(i4_kind)) - select type(input_data) - type is(integer(i4_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) - class default - type_error = .true. - end select - type is(integer(i8_kind)) - select type(input_data) - type is(integer(i8_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) - class default - type_error = .true. - end select - type is(real(r4_kind)) - select type(input_data) - type is(real(r4_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) - class default - type_error = .true. - end select - type is(real(r8_kind)) - select type(input_data) - type is(real(r8_kind)) - buffer(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) = input_data(1:n1, 1:n2, 1:n3, 1:n4, 1:n5) - class default - type_error = .true. - end select - end select - if( type_error ) call mpp_error (FATAL,'add_to_buffer_5d: mismatch between allocated buffer and input data types'//& - 'for field:'// field_name) -end subroutine add_to_buffer_5d +end subroutine initialize_buffer !> @brief Adds the axis ids to the buffer object subroutine add_axis_ids(this, axis_ids) - class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object - integer, intent(in) :: axis_ids(:) !< Axis ids to add + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: axis_ids(:) !< Axis ids to add this%axis_ids = axis_ids end subroutine @@ -1455,7 +291,7 @@ subroutine add_axis_ids(this, axis_ids) function get_axis_ids(this) & result(res) - class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object integer, allocatable :: res(:) if (allocated(this%axis_ids)) then @@ -1470,8 +306,7 @@ function get_axis_ids(this) & !! @return the field id of the buffer function get_field_id(this) & result(res) - - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object integer :: res res = this%field_id @@ -1479,16 +314,16 @@ end function get_field_id !> @brief set the field id of the buffer subroutine set_field_id(this, field_id) - class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object - integer, intent(in) :: field_id !< field id of the buffer + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: field_id !< field id of the buffer this%field_id = field_id end subroutine set_field_id !> @brief set the field id of the buffer subroutine set_yaml_id(this, yaml_id) - class(fmsDiagOutputBufferContainer_type), intent(inout) :: this !< Buffer object - integer, intent(in) :: yaml_id !< yaml id of the buffer + class(fmsDiagOutputBuffer_type), intent(inout) :: this !< Buffer object + integer, intent(in) :: yaml_id !< yaml id of the buffer this%yaml_id = yaml_id end subroutine set_yaml_id @@ -1498,7 +333,7 @@ end subroutine set_yaml_id function get_yaml_id(this) & result(res) - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< Buffer object + class(fmsDiagOutputBuffer_type), intent(in) :: this !< Buffer object integer :: res res = this%yaml_id @@ -1506,9 +341,9 @@ end function get_yaml_id !> @brief Write the buffer to the file subroutine write_buffer(this, fileobj, unlim_dim_level) - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write - class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to - integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + class(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension select type(fileobj) type is (FmsNetcdfFile_t) @@ -1525,85 +360,76 @@ end subroutine write_buffer !> @brief Write the buffer to the FmsNetcdfFile_t fileobj subroutine write_buffer_wrapper_netcdf(this, fileobj, unlim_dim_level) - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write - type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to - integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension character(len=:), allocatable :: varname !< name of the variable varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() - select type(buffer_obj=>this%diag_buffer_obj) - type is (outputBuffer0d_type) - call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) - type is (outputBuffer1d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer2d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer3d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer4d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer5d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - class default - call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& - " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + select case(this%ndim) + case (0) + call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) end select end subroutine write_buffer_wrapper_netcdf !> @brief Write the buffer to the FmsNetcdfDomainFile_t fileobj subroutine write_buffer_wrapper_domain(this, fileobj, unlim_dim_level) - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write - type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to - integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension character(len=:), allocatable :: varname !< name of the variable varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() - select type(buffer_obj=>this%diag_buffer_obj) - type is (outputBuffer0d_type) - call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) - type is (outputBuffer1d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer2d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer3d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer4d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer5d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - class default - call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& - " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + select case(this%ndim) + case (0) + call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) end select end subroutine write_buffer_wrapper_domain !> @brief Write the buffer to the FmsNetcdfUnstructuredDomainFile_t fileobj subroutine write_buffer_wrapper_u(this, fileobj, unlim_dim_level) - class(fmsDiagOutputBufferContainer_type), intent(in) :: this !< buffer object to write - type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to - integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension + class(fmsDiagOutputBuffer_type), intent(in) :: this !< buffer object to write + type(FmsNetcdfUnstructuredDomainFile_t), intent(in) :: fileobj !< fileobj to write to + integer, optional, intent(in) :: unlim_dim_level !< unlimited dimension character(len=:), allocatable :: varname !< name of the variable varname = diag_yaml%diag_fields(this%yaml_id)%get_var_outname() - select type(buffer_obj=>this%diag_buffer_obj) - type is (outputBuffer0d_type) - call write_data(fileobj, varname, buffer_obj%buffer(1), unlim_dim_level=unlim_dim_level) - type is (outputBuffer1d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer2d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer3d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer4d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - type is (outputBuffer5d_type) - call write_data(fileobj, varname, buffer_obj%buffer, unlim_dim_level=unlim_dim_level) - class default - call mpp_error(FATAL, "The field:"//trim(varname)//" does not have a valid buffer object type."//& - " Only 0d, 1d, 2d, 3d, 4d, and 5d buffers are supported.") + select case(this%ndim) + case (0) + call write_data(fileobj, varname, this%buffer(1,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (1) + call write_data(fileobj, varname, this%buffer(:,1,1,1,1), unlim_dim_level=unlim_dim_level) + case (2) + call write_data(fileobj, varname, this%buffer(:,:,1,1,1), unlim_dim_level=unlim_dim_level) + case (3) + call write_data(fileobj, varname, this%buffer(:,:,:,1,1), unlim_dim_level=unlim_dim_level) + case (4) + call write_data(fileobj, varname, this%buffer(:,:,:,:,1), unlim_dim_level=unlim_dim_level) + case (5) + call write_data(fileobj, varname, this%buffer(:,:,:,:,:), unlim_dim_level=unlim_dim_level) end select end subroutine write_buffer_wrapper_u #endif diff --git a/test_fms/diag_manager/test_diag_buffer.F90 b/test_fms/diag_manager/test_diag_buffer.F90 index c9dc7374e0..e339e9055e 100644 --- a/test_fms/diag_manager/test_diag_buffer.F90 +++ b/test_fms/diag_manager/test_diag_buffer.F90 @@ -1,189 +1,134 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This program tests the output buffer functionality program test_diag_buffer #ifdef use_yaml - use fms_diag_output_buffer_mod - use platform_mod - use diag_data_mod, only: i4, i8, r4, r8 + use fms_diag_output_buffer_mod, only: fmsDiagOutputBuffer_type + use platform_mod, only: r8_kind, r4_kind, i8_kind, i4_kind + use fms_mod, only: string, fms_init, fms_end + use mpp_mod, only: mpp_error, FATAL + use diag_data_mod, only: i4, i8, r4, r8 implicit none - type(outputBuffer0d_type) :: buffobj0(10) - type(outputBuffer1d_type) :: buffobj1 - type(outputBuffer2d_type) :: buffobj2 - type(outputBuffer3d_type) :: buffobj3 - type(outputBuffer4d_type) :: buffobj4 - type(outputBuffer5d_type) :: buffobj5 - class(*),allocatable :: p_val, p_data1(:), p_data2(:,:) - real(r8_kind) :: r8_data - real(r4_kind) :: r4_data - integer(i8_kind) :: i8_data - integer(i4_kind) :: i4_data - integer :: buff_id - class(*), pointer :: remap_buffer_out(:,:,:,:,:) - integer :: i - real(4) :: arr(9) - real(4), allocatable :: arr1d(:) - class(*), allocatable :: arr2d(:,:) - integer(8), allocatable :: i8arr2d(:,:) - real(8), allocatable :: r8val - class(*), allocatable :: arr3d(:,:,:), arr4d(:,:,:,:), arr5d(:,:,:,:,:) - integer(8), allocatable :: i8arr3d(:,:,:), i8arr4d(:,:,:,:), i8arr5d(:,:,:,:,:) - logical :: test_5d = .true. - character(len=4) :: fname = 'test' - - !! 0d - ! allocate some buffers - do i=1, 10 - call buffobj0(i)%allocate_buffer(r8_data, fname) - call buffobj0(i)%initialize_buffer( real(i, kind=r8_kind) , fname) - end do - ! add some values - call buffobj0(5)%add_to_buffer(real(-1, kind=r8_kind), fname) - ! get the buffer data - !allocate(real(8) :: p_val) - !allocate(r8val) - call buffobj0(5)%get_buffer(p_val, fname) - select type(p_val) - type is(real(r8_kind)) - print *, p_val - r8val = p_val - end select - ! get the 5d remapped buffer data - remap_buffer_out => buffobj0(5)%remap_buffer(fname, .false.) - ! check output from object and remapped buffer - print *, r8val - call print_5d(remap_buffer_out) - do i=1, 10 - call buffobj0(i)%flush_buffer() - enddo - - !! 1d - ! allocate a buffer to the given type and get it's id - call buffobj1%allocate_buffer(r4_data, 10, fname) - !! init to given value - call buffobj1%initialize_buffer( real(0.1, kind=r4_kind), fname ) - !! add some values to the buffer - arr = 4.0 - call buffobj1%add_to_buffer(arr, fname) - !! get the buffer - allocate(real(8) :: p_data1(10)) - allocate(arr1d(10)) - call buffobj1%get_buffer(p_data1, fname) - select type(p_data1) - type is(real(4)) - print *, p_data1 - arr1d = p_data1 - end select - !! get the remapped buffer - remap_buffer_out => buffobj1%remap_buffer(fname, .false.) - !! check output - print *, arr1d - call print_5d(remap_buffer_out) - call buffobj1%flush_buffer() - print *, '********** 2d **********' - - !! 2d - ! allocate a buffer to the given type and get it's id - call buffobj2%allocate_buffer(i4_data, (/ 5, 10 /), fname ) - !!! init to given value - call buffobj2%initialize_buffer( int(2, kind=i4_kind), fname ) - !! set some values in the buffer - allocate(integer(4) :: arr2d(5,10)) - arr2d = 1 - call buffobj2%add_to_buffer(arr2d, fname) - !!! get the buffer - call buffobj2%get_buffer(arr2d, fname) - !!! get the remapped buffer - remap_buffer_out => buffobj2%remap_buffer(fname, .false.) - !!! check output - select type(arr2d) - type is(integer(i4_kind)) - print *, arr2d - end select - call print_5d(remap_buffer_out) - call buffobj2%flush_buffer() - - !! 3d - ! allocate a buffer to the given type and get it's id - call buffobj3%allocate_buffer(i8_data, (/ 2, 2, 2/), fname ) - !! init to given value - call buffobj3%initialize_buffer( int(3, kind=i8_kind), fname ) - !! set some values in the buffer - allocate(i8arr3d(2,2,2)) - i8arr3d = 6 - call buffobj3%add_to_buffer(i8arr3d, fname) - !! get the buffer - call buffobj3%get_buffer(arr3d, fname) - !! get the remapped buffer - remap_buffer_out => buffobj3%remap_buffer(fname, .false.) - !! check output - select type (arr3d) - type is(integer(i8_kind)) - print *, arr3d - end select - call print_5d(remap_buffer_out) - call buffobj3%flush_buffer() + type(fmsDiagOutputBuffer_type) :: buffobj(6) !< Dummy output buffers + integer :: buff_sizes(5) !< Size of the buffer for each dimension + class(*),allocatable :: p_val(:,:,:,:,:) !< Dummy variable to get the data + integer :: i, j !< For do loops + real(r8_kind) :: r8_data !< Dummy r8 data + real(r4_kind) :: r4_data !< Dummy r4 data + integer(i8_kind) :: i8_data !< Dummy i8 data + integer(i4_kind) :: i4_data !< Dummy i4 data + character(len=4) :: fname = 'test' !< Dummy name for error messages - !! 4d - ! allocate a buffer to the given type and get it's id - call buffobj4%allocate_buffer(i8_data, (/ 2, 2, 2, 2/), fname) - !! init to given value - call buffobj4%initialize_buffer( int(4, kind=i8_kind), fname ) - !! set some values in the buffer - allocate(i8arr4d(2,2,2,2)) - i8arr4d = 8 - call buffobj4%add_to_buffer(i8arr4d, fname) - !! get the buffer - call buffobj4%get_buffer(arr4d, fname) - !! get the remapped buffer - remap_buffer_out => buffobj4%remap_buffer(fname, .false.) - !! check output - select type (arr4d) - type is(integer(i8_kind)) - print *, arr4d - end select - call print_5d(remap_buffer_out) - call buffobj4%flush_buffer() + call fms_init - !! 5d - call buffobj5%allocate_buffer(i8_data, (/ 2, 2, 2, 2, 2/), fname ) - !! init to given value - call buffobj5%initialize_buffer( int(5, kind=i8_kind), fname ) - !! get the remapped buffer - remap_buffer_out => buffobj5%remap_buffer(fname, .false.) - !! set some values in the buffer - allocate(i8arr5d(2,2,2,2,2)) - i8arr5d = 10 - call buffobj5%add_to_buffer(i8arr5d, fname) - !! get the buffer - call buffobj5%get_buffer(arr5d, fname) - !! check output - select type (arr4d) - type is(integer(i8_kind)) - print *, arr4d - end select - call print_5d(remap_buffer_out) - call buffobj5%flush_buffer() - - contains - - ! just prints polymorphic data types - subroutine print_5d(val) - class(*), intent(in) :: val(:,:,:,:,:) + !< Test the r8_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(r8_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer( real(i, kind=r8_kind) , fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (real(kind=r8_kind)) + if (any(p_val .ne. real(i, kind=r8_kind))) & + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "r8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do - select type (val) - type is (real(r4_kind)) - print *, "5d:", val - type is (real(r8_kind)) - print *, "5d:", val - type is (integer(i4_kind)) - print *, "5d:",val - type is (integer(i8_kind)) - print *, "5d:",val - end select - end subroutine + !< Test the r4_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(r4_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer( real(i, kind=r4_kind) , fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (real(kind=r4_kind)) + if (any(p_val .ne. real(i, kind=r4_kind))) & + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "r4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + !< Test the i8_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(i8_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer( int(i, kind=i8_kind) , fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (integer(kind=i8_kind)) + if (any(p_val .ne. int(i, kind=i8_kind))) & + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "i8_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + !< Test the i4_buffer + buff_sizes = 1 + do i=0, 5 + if (i < 5) buff_sizes(i+1) = i+5 + call buffobj(i+1)%allocate_buffer(i4_data, i, buff_sizes, fname) + call buffobj(i+1)%initialize_buffer( int(i, kind=i4_kind) , fname) + call buffobj(i+1)%get_buffer(p_val, fname) + select type(p_val) + type is (integer(kind=i4_kind)) + if (any(p_val .ne. int(i, kind=i4_kind))) & + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not initialized to the correct value") + do j = 1, 5 + if (size(p_val, j) .ne. buff_sizes(j)) & + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct size") + enddo + class default + call mpp_error(FATAL, "i4_buffer:: The "//string(i)//"d buffer was not allocated to the correct type") + end select + deallocate(p_val) + call buffobj(i+1)%flush_buffer() + end do + call fms_end() #endif end program