diff --git a/src/hash/hist_hash_table.F90 b/src/hash/hist_hash_table.F90 index 6d9ab4a..fb9f38a 100644 --- a/src/hash/hist_hash_table.F90 +++ b/src/hash/hist_hash_table.F90 @@ -1,7 +1,8 @@ !!XXgoldyXX: To do, statistics output module hist_hash_table - use hist_hashable, only: hist_hashable_t + use, intrinsic :: iso_fortran_env, only: output_unit + use hist_hashable, only: hist_hashable_t implicit none private @@ -96,16 +97,16 @@ module hist_hash_table integer, parameter :: gen_hash_key_offset = 21467 ! z'000053db' integer, parameter :: tbl_max_idx = 15 - integer, parameter, dimension(0:tbl_max_idx) :: tbl_gen_hash_key = & - (/ 61, 59, 53, 47, 43, 41, 37, 31, 29, 23, 17, 13, 11, 7, 3, 1 /) + integer, parameter :: tbl_gen_hash_key(0:tbl_max_idx) = & + [61, 59, 53, 47, 43, 41, 37, 31, 29, 23, 17, 13, 11, 7, 3, 1] integer, parameter :: table_factor_size = 8 ! Table size / # entries integer, parameter :: table_overflow_factor = 4 ! # entries / Overflow size type :: table_entry_t ! Any table entry contains a key and a value - class(hist_hashable_t), pointer :: entry_value => NULL() - type(table_entry_t), pointer :: next => NULL() + class(hist_hashable_t), pointer :: entry_value => null() + type(table_entry_t), pointer :: next => null() contains procedure :: finalize_table_entry end type table_entry_t @@ -133,17 +134,18 @@ module hist_hash_table private :: have_error ! Has a called routine detected an error? private :: clear_optstring ! Clear a string, if present -CONTAINS +contains !####################################################################### - logical function have_error(errmsg) + pure function have_error(errmsg) result(has_error) ! Return .true. iff is present and contains text character(len=*), optional, intent(in) :: errmsg + logical :: has_error - have_error = present(errmsg) - if (have_error) then - have_error = len_trim(errmsg) > 0 + has_error = present(errmsg) + if (has_error) then + has_error = len_trim(errmsg) > 0 end if end function have_error @@ -151,6 +153,9 @@ end function have_error subroutine clear_optstring(str) ! clear if it is present + ! + ! Fortitude: + ! allow(assumed-size-character-intent) character(len=*), optional, intent(inout) :: str if (present(str)) then @@ -176,9 +181,9 @@ end subroutine finalize_table_entry subroutine hash_table_initialize_table(this, tbl_size, key_off) ! Initialize this table. ! Dummy arguments - class(hist_hash_table_t) :: this - integer, intent(in) :: tbl_size ! new table size - integer, optional, intent(in) :: key_off ! key offset + class(hist_hash_table_t), intent(inout) :: this + integer, intent(in) :: tbl_size ! new table size + integer, optional, intent(in) :: key_off ! key offset ! Clear this table so it can be initialized if (allocated(this%primary_table)) then @@ -198,7 +203,7 @@ end subroutine hash_table_initialize_table subroutine hash_table_deallocate_table(this) ! Deallocate the hash table (if present) ! Dummy argument - class(hist_hash_table_t) :: this + class(hist_hash_table_t), intent(inout) :: this ! Local variable integer :: entry_index @@ -228,8 +233,10 @@ integer function hash_table_key_hash(this, string, errmsg) result(hash_key) ! ! Arguments: ! - class(hist_hash_table_t) :: this + class(hist_hash_table_t), intent(in) :: this character(len=*), intent(in) :: string + ! Fortitude: + ! allow(assumed-size-character-intent) character(len=*), optional, intent(out) :: errmsg character(len=*), parameter :: subname = 'HASH_TABLE_KEY_HASH' ! @@ -257,9 +264,14 @@ integer function hash_table_key_hash(this, string, errmsg) result(hash_key) write(errmsg, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & hash_key, ' out of bounds, [1, ', this%table_size, ']' else - write(6, '(2a,2(i0,a))') subname, ' ERROR: Key Hash, ', & - hash_key, ' out of bounds, [1, ', this%table_size, ']' - STOP 1 + ! This else-block is only used for unit testing. Eventually + ! the unit tests should be updated to use 'errmsg', and this + ! code block should be removed (along with making 'errmsg' + ! required. + write(output_unit, '(2a,2(i0,a))') subname, & + ' ERROR: Key Hash, ', hash_key, ' out of bounds, [1, ', & + this%table_size, ']' + stop 1 end if end if @@ -279,8 +291,10 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) ! ! Arguments: ! - class(hist_hash_table_t) :: this + class(hist_hash_table_t), intent(in) :: this character(len=*), intent(in) :: key + ! Fortitude: + ! allow(assumed-size-character-intent) character(len=*), optional, intent(out) :: errmsg class(hist_hashable_t), pointer :: tbl_val ! @@ -293,7 +307,7 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) call clear_optstring(errmsg) nullify(tbl_val) hash_key = this%key_hash(key, errmsg=errmsg) - ASSOCIATE(tbl_entry => this%primary_table(hash_key)) + associate(tbl_entry => this%primary_table(hash_key)) if (have_error(errmsg)) then errmsg = trim(errmsg)//', called from '//subname else if (associated(tbl_entry%entry_value)) then @@ -316,7 +330,7 @@ function hash_table_table_value(this, key, errmsg) result(tbl_val) end do end if end if - END ASSOCIATE + end associate if ((.not. associated(tbl_val)) .and. present(errmsg)) then if (.not. have_error(errmsg)) then ! Still need to test for empty @@ -340,9 +354,11 @@ subroutine hash_table_add_hash_key(this, newval, errmsg) !----------------------------------------------------------------------- ! Dummy arguments: - class(hist_hash_table_t) :: this - class(hist_hashable_t), target :: newval - character(len=*), optional, intent(out) :: errmsg + class(hist_hash_table_t) , intent(inout) :: this + class(hist_hashable_t), target , intent(in) :: newval + ! Fortitude: + ! allow(assumed-size-character-intent) + character(len=*), optional, intent(out) :: errmsg ! Local variables integer :: hash_ind integer :: ovflw_len @@ -363,7 +379,7 @@ subroutine hash_table_add_hash_key(this, newval, errmsg) "' already in table" end if else - ASSOCIATE(tbl_entry => this%primary_table(hash_ind)) + associate(tbl_entry => this%primary_table(hash_ind)) if (associated(tbl_entry%entry_value)) then ! We have a collision, make a new entry allocate(new_entry) @@ -391,7 +407,7 @@ subroutine hash_table_add_hash_key(this, newval, errmsg) else tbl_entry%entry_value => newval end if - END ASSOCIATE + end associate end if this%num_keys = this%num_keys + 1 diff --git a/src/hash/hist_hashable.F90 b/src/hash/hist_hashable.F90 index 5ec3636..764d0d4 100644 --- a/src/hash/hist_hashable.F90 +++ b/src/hash/hist_hashable.F90 @@ -28,20 +28,21 @@ module hist_hashable ! Abstract interface for key procedure of hist_hashable_t class abstract interface - function hist_hashable_get_key(hashable) + function hist_hashable_get_key(hashable) result(key) import :: hist_hashable_t + implicit none class(hist_hashable_t), intent(in) :: hashable - character(len=:), allocatable :: hist_hashable_get_key + character(len=:), allocatable :: key end function hist_hashable_get_key end interface -CONTAINS +contains !####################################################################### subroutine new_hashable_char(name_in, new_obj) - character(len=*), intent(in) :: name_in - type(hist_hashable_char_t), pointer :: new_obj + character(len=*), intent(in) :: name_in + type(hist_hashable_char_t), pointer, intent(inout) :: new_obj if (associated(new_obj)) then deallocate(new_obj) @@ -52,19 +53,19 @@ end subroutine new_hashable_char !####################################################################### - function hist_hashable_char_get_key(hashable) + function hist_hashable_char_get_key(hashable) result(key) ! Return the hashable char class key (name) class(hist_hashable_char_t), intent(in) :: hashable - character(len=:), allocatable :: hist_hashable_char_get_key + character(len=:), allocatable :: key - hist_hashable_char_get_key = hashable%name + key = hashable%name end function hist_hashable_char_get_key !####################################################################### subroutine new_hashable_int(val_in, new_obj) - integer, intent(in) :: val_in - type(hist_hashable_int_t), pointer :: new_obj + integer, intent(in) :: val_in + type(hist_hashable_int_t), pointer, intent(inout) :: new_obj if (associated(new_obj)) then deallocate(new_obj) @@ -75,24 +76,25 @@ end subroutine new_hashable_int !####################################################################### - function hist_hashable_int_get_key(hashable) + function hist_hashable_int_get_key(hashable) result(key) ! Return the hashable int class key (value ==> string) class(hist_hashable_int_t), intent(in) :: hashable - character(len=:), allocatable :: hist_hashable_int_get_key + character(len=:), allocatable :: key character(len=32) :: key_str write(key_str, '(i0)') hashable%val() - hist_hashable_int_get_key = trim(key_str) + key = trim(key_str) end function hist_hashable_int_get_key !####################################################################### - integer function hist_hashable_int_get_val(hashable) + function hist_hashable_int_get_val(hashable) result(val) ! Return the hashable int class value class(hist_hashable_int_t), intent(in) :: hashable + integer :: val - hist_hashable_int_get_val = hashable%value + val = hashable%value end function hist_hashable_int_get_val end module hist_hashable diff --git a/src/hist_api.F90 b/src/hist_api.F90 index 56b8046..ddedac7 100644 --- a/src/hist_api.F90 +++ b/src/hist_api.F90 @@ -20,7 +20,7 @@ module hist_api module procedure hist_field_norm_value_2d end interface hist_field_norm_value -CONTAINS +contains !####################################################################### @@ -30,7 +30,7 @@ function hist_new_field(diag_name_in, std_name_in, long_name_in, units_in, & cell_methods, errors) result(new_field) use hist_msg_handler, only: hist_have_error, hist_log_messages, ERROR use hist_field, only: hist_field_initialize, hist_field_info_t - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 type(hist_field_info_t), pointer :: new_field character(len=*), intent(in) :: diag_name_in @@ -55,13 +55,13 @@ function hist_new_field(diag_name_in, std_name_in, long_name_in, units_in, & type(hist_log_messages), optional, intent(inout) :: errors integer :: astat - character(len=128) :: errmsg + character(len=256) :: errmsg character(len=*), parameter :: subname = 'hist_new_field' if (.not. hist_have_error(errors=errors)) then - allocate(new_field, stat=astat) + allocate(new_field, stat=astat, errmsg=errmsg) if ((astat /= 0) .and. present(errors)) then - call errors%new_error(subname//' Unable to allocate ') + call errors%new_error(subname//' Unable to allocate , error: '//errmsg) end if end if if (.not. hist_have_error(errors=errors)) then @@ -91,7 +91,7 @@ subroutine hist_new_buffer(field, buff_shape, horiz_axis_ind, & use hist_field, only: hist_field_info_t ! Dummy arguments - class(hist_field_info_t), pointer :: field + class(hist_field_info_t), pointer, intent(inout) :: field integer, intent(in) :: buff_shape(:) integer, intent(in) :: horiz_axis_ind character(len=*), intent(in) :: accum_type @@ -233,7 +233,7 @@ subroutine hist_field_accumulate_1d(field, data, cols_or_block, & use hist_msg_handler, only: hist_add_message, VERBOSE, hist_add_error use hist_field, only: hist_field_info_t use hist_buffer, only: hist_buff_1d_t, hist_buffer_t - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 ! Dummy arguments class(hist_field_info_t), pointer, intent(inout) :: field @@ -260,13 +260,12 @@ subroutine hist_field_accumulate_1d(field, data, cols_or_block, & call logger%add_stack_frame(ERROR, __FILE__, __LINE__ - 3, & subname=subname) exit - else - call hist_add_message(subname, VERBOSE, & - "Accumulated data for", & - msgstr2=trim(field%diag_name())//", Buffer type, ", & - msgstr3=trim(buff%buffer_type()), & - logger=logger) end if + call hist_add_message(subname, VERBOSE, & + 'Accumulated data for', & + msgstr2=trim(field%diag_name())//', Buffer type, ', & + msgstr3=trim(buff%buffer_type()), & + logger=logger) class default call hist_add_error(subname, 'invalid buffer type', errors=logger) end select @@ -287,7 +286,7 @@ subroutine hist_field_accumulate_2d(field, data, cols_or_block, & use hist_msg_handler, only: hist_add_message, VERBOSE, hist_add_error use hist_field, only: hist_field_info_t use hist_buffer, only: hist_buff_2d_t, hist_buffer_t - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 ! Dummy arguments class(hist_field_info_t), pointer, intent(inout) :: field @@ -314,13 +313,12 @@ subroutine hist_field_accumulate_2d(field, data, cols_or_block, & call logger%add_stack_frame(ERROR, __FILE__, __LINE__ - 3, & subname=subname) exit - else - call hist_add_message(subname, VERBOSE, & - "Accumulated data for", & - msgstr2=trim(field%diag_name())//", Buffer type, ", & - msgstr3=trim(buff%buffer_type()), & - logger=logger) end if + call hist_add_message(subname, VERBOSE, & + 'Accumulated data for', & + msgstr2=trim(field%diag_name())//', Buffer type, ', & + msgstr3=trim(buff%buffer_type()), & + logger=logger) class default call hist_add_error(subname, 'invalid buffer type', errors=logger) end select @@ -340,7 +338,7 @@ subroutine hist_field_norm_value_1d(field, norm_val, logger) use hist_msg_handler, only: hist_log_messages, hist_have_error, ERROR use hist_msg_handler, only: hist_add_message, VERBOSE, hist_add_error use hist_field, only: hist_field_info_t - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 ! Dummy arguments class(hist_field_info_t), intent(inout) :: field @@ -364,8 +362,8 @@ subroutine hist_field_norm_value_1d(field, norm_val, logger) subname=subname) else call hist_add_message(subname, VERBOSE, & - "Accumulated data for", & - msgstr2=trim(field%diag_name())//", Buffer type, ", & + 'Accumulated data for', & + msgstr2=trim(field%diag_name())//', Buffer type, ', & msgstr3=trim(buff%buffer_type()), & logger=logger) end if @@ -383,7 +381,7 @@ subroutine hist_field_norm_value_2d(field, norm_val, logger) use hist_msg_handler, only: hist_log_messages, hist_have_error, ERROR use hist_msg_handler, only: hist_add_message, VERBOSE, hist_add_error use hist_field, only: hist_field_info_t - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 ! Dummy arguments class(hist_field_info_t), intent(inout) :: field @@ -407,8 +405,8 @@ subroutine hist_field_norm_value_2d(field, norm_val, logger) subname=subname) else call hist_add_message(subname, VERBOSE, & - "Accumulated data for", & - msgstr2=trim(field%diag_name())//", Buffer type, ", & + 'Accumulated data for', & + msgstr2=trim(field%diag_name())//', Buffer type, ', & msgstr3=trim(buff_ptr%buffer_type()), & logger=logger) end if diff --git a/src/hist_buffer.F90 b/src/hist_buffer.F90 index c951ac6..f7ec584 100644 --- a/src/hist_buffer.F90 +++ b/src/hist_buffer.F90 @@ -1,6 +1,6 @@ module hist_buffer - use ISO_FORTRAN_ENV, only: REAL64 - use hist_hashable, only: hist_hashable_t + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 + use hist_hashable, only: hist_hashable_t implicit none private @@ -15,20 +15,25 @@ module hist_buffer integer, parameter, public :: hist_accum_avg = 4 ! sample average integer, parameter, public :: hist_accum_var = 5 ! sample standard deviation + ! Number of accumulation types defined above + integer, parameter, public :: hist_num_accum_types = 5 + integer, parameter :: as_len = 36 - character(len=as_len), parameter, public :: accum_strings(5) = (/ & + character(len=as_len), parameter, public :: & + accum_strings(hist_num_accum_types) = [ & 'last sampled value ', & 'minimum of sampled values ', & 'maximum of sampled values ', & 'average of sampled values ', & - 'standard deviation of sampled values' /) + 'standard deviation of sampled values'] - character(len=3), parameter, public :: accum_abbrev(5) = & - (/ 'lst', 'min', 'max', 'avg', 'var' /) + character(len=3), parameter, public :: & + accum_abbrev(hist_num_accum_types) = & + ['lst', 'min', 'max', 'avg', 'var'] type, abstract, public :: hist_buffer_t ! hist_buffer_t is an abstract base class for hist_outfld buffers - class(hist_hashable_t), pointer :: field_info => NULL() + class(hist_hashable_t), pointer :: field_info => null() integer, private :: vol = -1 ! For host output integer, private :: horiz_axis_ind = 0 integer, private :: rank = 0 @@ -37,7 +42,7 @@ module hist_buffer integer, allocatable, private :: block_begs(:) integer, allocatable, private :: block_ends(:) character(len=:), allocatable, private :: buff_type - class(hist_buffer_t), pointer :: next => NULL() + class(hist_buffer_t), pointer :: next => null() contains procedure :: field => get_field_info procedure :: volume => get_volume @@ -56,7 +61,7 @@ module hist_buffer real(REAL64), allocatable :: data(:) real(REAL64), allocatable :: var_buffer(:) integer, allocatable, private :: num_samples(:) - CONTAINS + contains procedure :: clear => buff_1d_clear procedure :: accumulate => buff_1d_accum procedure :: norm_value => buff_1d_value @@ -67,7 +72,7 @@ module hist_buffer real(REAL64), allocatable :: data(:,:) real(REAL64), allocatable :: var_buffer(:,:) integer, allocatable, private :: num_samples(:) - CONTAINS + contains procedure :: clear => buff_2d_clear procedure :: accumulate => buff_2d_accum procedure :: norm_value => buff_2d_value @@ -80,6 +85,7 @@ module hist_buffer subroutine hist_buff_sub_log(this, logger) use hist_msg_handler, only: hist_log_messages import :: hist_buffer_t + implicit none class(hist_buffer_t), intent(inout) :: this type(hist_log_messages), optional, intent(inout) :: logger end subroutine hist_buff_sub_log @@ -88,12 +94,13 @@ end subroutine hist_buff_sub_log abstract interface subroutine hist_buff_init(this, field_in, volume_in, horiz_axis_in, & accum_type_in, shape_in, block_sizes_in, block_ind_in, logger) - use hist_msg_handler, only: hist_log_messages - use ISO_FORTRAN_ENV, only: REAL64 + use hist_msg_handler, only: hist_log_messages + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 import :: hist_buffer_t import :: hist_hashable_t + implicit none class(hist_buffer_t), intent(inout) :: this - class(hist_hashable_t), pointer :: field_in + class(hist_hashable_t), pointer, intent(in) :: field_in integer, intent(in) :: volume_in integer, intent(in) :: horiz_axis_in integer, intent(in) :: accum_type_in @@ -108,33 +115,35 @@ end subroutine hist_buff_init subroutine hist_buff_clear(this, logger) use hist_msg_handler, only: hist_log_messages import :: hist_buffer_t + implicit none class(hist_buffer_t), intent(inout) :: this type(hist_log_messages), optional, intent(inout) :: logger end subroutine hist_buff_clear end interface -CONTAINS +contains !####################################################################### - function get_field_info(this) + function get_field_info(this) result(field_info) class(hist_buffer_t), intent(in) :: this - class(hist_hashable_t), pointer :: get_field_info + class(hist_hashable_t), pointer :: field_info - get_field_info => this%field_info + field_info => this%field_info end function get_field_info !####################################################################### - integer function get_volume(this) + pure function get_volume(this) result(volume) class(hist_buffer_t), intent(in) :: this + integer :: volume - get_volume = this%vol + volume = this%vol end function get_volume !####################################################################### - function get_shape(this) result(fshape) + pure function get_shape(this) result(fshape) class(hist_buffer_t), intent(in) :: this integer, allocatable :: fshape(:) @@ -145,14 +154,15 @@ end function get_shape !####################################################################### - integer function horiz_axis_index(this) + pure function horiz_axis_index(this) result(axis_index) class(hist_buffer_t), intent(in) :: this + integer :: axis_index - horiz_axis_index = this%horiz_axis_ind + axis_index = this%horiz_axis_ind end function horiz_axis_index !####################################################################### - logical function check_status(this, logger, filename, line) + function check_status(this, logger, filename, line) result(is_valid) ! Check to see if this buffer is properly initialized use hist_msg_handler, only: hist_log_messages, hist_add_error, ERROR @@ -161,13 +171,14 @@ logical function check_status(this, logger, filename, line) type(hist_log_messages), optional, intent(inout) :: logger character(len=*), optional, intent(in) :: filename integer, optional, intent(in) :: line + logical :: is_valid ! Local variable character(len=*), parameter :: subname = 'check_status' - check_status = .true. - if ( (this%horiz_axis_index() < 1) .or. & - (.not. allocated(this%field_shape)) ) then - check_status = .false. + is_valid = .true. + if ((this%horiz_axis_index() < 1) .or. & + (.not. allocated(this%field_shape))) then + is_valid = .false. call hist_add_error(subname, & "buffer not properly initialized '", errors=logger) if (present(filename) .and. present(line) .and. present(logger)) then @@ -179,11 +190,12 @@ end function check_status !####################################################################### - logical function has_blocks(this) + pure function has_blocks(this) result(blocked) ! Dummy argument - class(hist_buffer_t), intent(inout) :: this + class(hist_buffer_t), intent(in) :: this + logical :: blocked - has_blocks = allocated(this%block_begs) .and. allocated(this%block_ends) + blocked = allocated(this%block_begs) .and. allocated(this%block_ends) end function has_blocks @@ -196,7 +208,7 @@ subroutine init_buffer(this, field_in, volume_in, horiz_axis_in, & ! Dummy arguments class(hist_buffer_t), intent(inout) :: this - class(hist_hashable_t), pointer :: field_in + class(hist_hashable_t), pointer, intent(in) :: field_in integer, intent(in) :: volume_in integer, intent(in) :: horiz_axis_in integer, intent(in) :: accum_type_in @@ -207,6 +219,7 @@ subroutine init_buffer(this, field_in, volume_in, horiz_axis_in, & ! Local variables integer :: astat integer :: hsize + character(len=256) :: errmsg character(len=*), parameter :: subname = 'init_buffer' ! Sanity check @@ -220,11 +233,11 @@ subroutine init_buffer(this, field_in, volume_in, horiz_axis_in, & this%vol = volume_in this%horiz_axis_ind = horiz_axis_in this%accum_type = accum_type_in - allocate(this%field_shape(size(shape_in, 1)), stat=astat) + allocate(this%field_shape(size(shape_in, 1)), stat=astat, errmsg=errmsg) if (astat == 0) then this%field_shape(:) = shape_in(:) else - call hist_add_alloc_error('field_shape', __FILE__, __LINE__ - 4, & + call hist_add_alloc_error('field_shape, error: '//errmsg, __FILE__, __LINE__ - 4, & subname=subname, errors=logger) end if end if @@ -264,26 +277,27 @@ subroutine buff_1d_clear(this, logger) type(hist_log_messages), optional, intent(inout) :: logger ! Local variables integer :: aerr + character(len=256) :: errmsg character(len=*), parameter :: subname = 'buff_1d_clear' if (.not. allocated(this%data)) then - allocate(this%data(this%field_shape(1)), stat=aerr) + allocate(this%data(this%field_shape(1)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('data', __FILE__, __LINE__ - 1, & + call hist_add_alloc_error('data, error: '//errmsg, __FILE__, __LINE__ - 1, & subname=subname, errors=logger) end if end if if (.not. allocated(this%var_buffer) .and. this%accum_type == hist_accum_var) then - allocate(this%var_buffer(this%field_shape(1)), stat=aerr) + allocate(this%var_buffer(this%field_shape(1)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('var_buffer', __FILE__, __LINE__ - 2, & + call hist_add_alloc_error('var_buffer, error: '//errmsg, __FILE__, __LINE__ - 2, & subname=subname, errors=logger) end if end if if (.not. allocated(this%num_samples)) then - allocate(this%num_samples(this%field_shape(1)), stat=aerr) + allocate(this%num_samples(this%field_shape(1)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('num_samples', __FILE__, __LINE__ - 1, & + call hist_add_alloc_error('num_samples, error: '//errmsg, __FILE__, __LINE__ - 1, & subname=subname, errors=logger) end if end if @@ -302,7 +316,7 @@ subroutine init_buff_1d(this, field_in, volume_in, horiz_axis_in, & use hist_msg_handler, only: hist_log_messages class(hist_buff_1d_t), intent(inout) :: this - class(hist_hashable_t), pointer :: field_in + class(hist_hashable_t), pointer, intent(in) :: field_in integer, intent(in) :: volume_in integer, intent(in) :: horiz_axis_in integer, intent(in) :: accum_type_in @@ -322,7 +336,7 @@ end subroutine init_buff_1d subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & fill_value, cole, logger) - use hist_msg_handler, only: hist_log_messages + use hist_msg_handler, only: hist_log_messages, hist_add_error ! Dummy arguments class(hist_buff_1d_t), intent(inout) :: this real(REAL64), intent(in) :: field(:) @@ -332,10 +346,12 @@ subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & integer, optional, intent(in) :: cole type(hist_log_messages), optional, intent(inout) :: logger ! Local variables - integer :: col_beg_use - integer :: col_end_use - integer :: ind1 - real(REAL64) :: fld_val, tmp + integer :: col_beg_use + integer :: col_end_use + integer :: ind1 + real(REAL64) :: fld_val, tmp + character(len=256) :: errmsg + character(len=*), parameter :: subname = 'buff_1d_accum' if (this%has_blocks()) then col_end_use = this%block_ends(cols_or_block) @@ -350,7 +366,6 @@ subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & end if end if - select case (this%accum_type) case (hist_accum_lst) do ind1 = col_beg_use, col_end_use @@ -450,7 +465,7 @@ subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & ! Only include the sample if it's not a fill value if (this%num_samples(ind1) == 0) then this%data(ind1) = fld_val - this%var_buffer(ind1) = 0._REAL64 + this%var_buffer(ind1) = 0.0_REAL64 this%num_samples(ind1) = this%num_samples(ind1) + 1 else tmp = this%data(ind1) @@ -466,7 +481,7 @@ subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & else if (this%num_samples(ind1) == 0) then this%data(ind1) = fld_val - this%var_buffer(ind1) = 0._REAL64 + this%var_buffer(ind1) = 0.0_REAL64 this%num_samples(ind1) = this%num_samples(ind1) + 1 else tmp = this%data(ind1) @@ -480,6 +495,10 @@ subroutine buff_1d_accum(this, field, cols_or_block, flag_xyfill, & end if end if end do + case default + ! This shouldn't trigger, so raise an error: + write(errmsg, *) 'un-recognized accumulation type: ', this%accum_type + call hist_add_error(subname, errmsg, errors=logger) end select end subroutine buff_1d_accum @@ -534,26 +553,27 @@ subroutine buff_2d_clear(this, logger) type(hist_log_messages), optional, intent(inout) :: logger ! Local variables integer :: aerr + character(len=256) :: errmsg character(len=*), parameter :: subname = 'buff_2d_clear' if (.not. allocated(this%data)) then - allocate(this%data(this%field_shape(1), this%field_shape(2)), stat=aerr) + allocate(this%data(this%field_shape(1), this%field_shape(2)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('data', __FILE__, __LINE__ - 1, & + call hist_add_alloc_error('data, error: '//errmsg, __FILE__, __LINE__ - 1, & subname=subname, errors=logger) end if end if if (.not. allocated(this%var_buffer) .and. this%accum_type == hist_accum_var) then - allocate(this%var_buffer(this%field_shape(1), this%field_shape(2)), stat=aerr) + allocate(this%var_buffer(this%field_shape(1), this%field_shape(2)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('var_buffer', __FILE__, __LINE__ - 2, & + call hist_add_alloc_error('var_buffer, error: '//errmsg, __FILE__, __LINE__ - 2, & subname=subname, errors=logger) end if end if if (.not. allocated(this%num_samples)) then - allocate(this%num_samples(this%field_shape(1)), stat=aerr) + allocate(this%num_samples(this%field_shape(1)), stat=aerr, errmsg=errmsg) if (aerr /= 0) then - call hist_add_alloc_error('num_samples', __FILE__, __LINE__ - 1, & + call hist_add_alloc_error('num_samples, error: '//errmsg, __FILE__, __LINE__ - 1, & subname=subname, errors=logger) end if end if @@ -572,7 +592,7 @@ subroutine init_buff_2d(this, field_in, volume_in, horiz_axis_in, & use hist_msg_handler, only: hist_log_messages class(hist_buff_2d_t), intent(inout) :: this - class(hist_hashable_t), pointer :: field_in + class(hist_hashable_t), pointer, intent(in) :: field_in integer, intent(in) :: volume_in integer, intent(in) :: horiz_axis_in integer, intent(in) :: accum_type_in @@ -592,7 +612,7 @@ end subroutine init_buff_2d subroutine buff_2d_accum(this, field, cols_or_block, flag_xyfill, & fill_value, cole, logger) - use hist_msg_handler, only: hist_log_messages + use hist_msg_handler, only: hist_log_messages, hist_add_error ! Dummy arguments class(hist_buff_2d_t), intent(inout) :: this real(REAL64), intent(in) :: field(:,:) @@ -602,10 +622,12 @@ subroutine buff_2d_accum(this, field, cols_or_block, flag_xyfill, & integer, optional, intent(in) :: cole type(hist_log_messages), optional, intent(inout) :: logger ! Local variables - integer :: col_beg_use - integer :: col_end_use - integer :: ind1, ind2 - real(REAL64) :: fld_val, tmp + integer :: col_beg_use + integer :: col_end_use + integer :: ind1, ind2 + real(REAL64) :: fld_val, tmp + character(len=256) :: errmsg + character(len=*), parameter :: subname = 'buff_2d_accum' if (this%has_blocks()) then ! For a blocked field, is a block index @@ -746,7 +768,7 @@ subroutine buff_2d_accum(this, field, cols_or_block, flag_xyfill, & ! Only include the sample if it's not a fill value if (this%num_samples(ind1) == 1) then this%data(ind1, ind2) = fld_val - this%var_buffer(ind1, ind2) = 0._REAL64 + this%var_buffer(ind1, ind2) = 0.0_REAL64 else tmp = this%data(ind1, ind2) this%data(ind1, ind2) = this%data(ind1, ind2) + & @@ -760,7 +782,7 @@ subroutine buff_2d_accum(this, field, cols_or_block, flag_xyfill, & else if (this%num_samples(ind1) == 1) then this%data(ind1, ind2) = fld_val - this%var_buffer(ind1, ind2) = 0._REAL64 + this%var_buffer(ind1, ind2) = 0.0_REAL64 else tmp = this%data(ind1, ind2) this%data(ind1, ind2) = this%data(ind1, ind2) + & @@ -776,6 +798,10 @@ subroutine buff_2d_accum(this, field, cols_or_block, flag_xyfill, & if (flag_xyfill) then call this%check_fill_value(field(col_beg_use:col_end_use, :), fill_value, logger) end if + case default + ! This shouldn't trigger, so raise an error: + write(errmsg, *) 'un-recognized accumulation type: ', this%accum_type + call hist_add_error(subname, errmsg, errors=logger) end select end subroutine buff_2d_accum @@ -795,20 +821,20 @@ subroutine buff_2d_check_fill(this, field, fill_value, logger) logical :: error_found error_found = .false. - do jdx = 2, this%field_shape(2) - do idx = 1, this%field_shape(1) + lev_loop: do jdx = 2, this%field_shape(2) + col_loop: do idx = 1, this%field_shape(1) if (field(idx,1) == fill_value .and. field(idx,jdx) /= fill_value .or. & field(idx,1) /= fill_value .and. field(idx,jdx) == fill_value) then write(errstr, '(a,i0)') 'ERROR: fill value applied inconsistently for column ', idx call hist_add_error('buff_2d_check_fill', errstr, errors=logger) error_found = .true. - exit + exit col_loop end if - end do + end do col_loop if (error_found) then - exit + exit lev_loop end if - end do + end do lev_loop end subroutine buff_2d_check_fill @@ -885,10 +911,14 @@ function buffer_factory(buffer_type, logger) result(newbuf) character(len=512) :: alloc_errmsg ! For buffer allocation integer :: aerr - type(hist_buff_1d_t), pointer :: real_1 => NULL() - type(hist_buff_2d_t), pointer :: real_2 => NULL() + type(hist_buff_1d_t), pointer :: real_1 + type(hist_buff_2d_t), pointer :: real_2 + ! Clear relevant pointers nullify(newbuf) + nullify(real_1) + nullify(real_2) + ! Create new buffer select case (trim(buffer_type)) case ('real_1') @@ -897,7 +927,7 @@ function buffer_factory(buffer_type, logger) result(newbuf) newbuf => real_1 else call hist_add_error(subname, & - "Failed to allocate real_1 buffer, errmsg = ", & + 'Failed to allocate real_1 buffer, errmsg = ', & errstr2=trim(alloc_errmsg), errors=logger) end if case ('real_2') @@ -906,7 +936,7 @@ function buffer_factory(buffer_type, logger) result(newbuf) newbuf => real_2 else call hist_add_error(subname, & - "Failed to allocate real_2 buffer, errmsg = ", & + 'Failed to allocate real_2 buffer, errmsg = ', & errstr2=trim(alloc_errmsg), errors=logger) end if case default diff --git a/src/hist_field.F90 b/src/hist_field.F90 index d600bf9..f3580a8 100644 --- a/src/hist_field.F90 +++ b/src/hist_field.F90 @@ -1,5 +1,5 @@ module hist_field - use ISO_FORTRAN_ENV, only: REAL64 + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 ! Module containing DDTs for history fields and associated routines use hist_hashable, only: hist_hashable_t @@ -31,11 +31,11 @@ module hist_field real(REAL64), private :: fillvalue integer, allocatable, private :: field_beg_dims(:) integer, allocatable, private :: field_end_dims(:) - + ! type kind rank? ! dimensions? - type(hist_field_info_t), pointer :: next => NULL() - class(hist_buffer_t), pointer :: buffers => NULL() + type(hist_field_info_t), pointer :: next => null() + class(hist_buffer_t), pointer :: buffers => null() contains procedure :: key => hist_field_info_get_key procedure :: diag_name => get_diag_name @@ -61,16 +61,16 @@ module hist_field final :: finalize_field end type hist_field_info_t -CONTAINS +contains !####################################################################### - function hist_field_info_get_key(hashable) + pure function hist_field_info_get_key(hashable) result(key) ! Return the hashable field info class key (diag_file_name) class(hist_field_info_t), intent(in) :: hashable - character(len=:), allocatable :: hist_field_info_get_key + character(len=:), allocatable :: key - hist_field_info_get_key = hashable%diag_file_name + key = hashable%diag_file_name end function hist_field_info_get_key !####################################################################### @@ -80,27 +80,29 @@ subroutine hist_field_initialize(field, diag_name_in, std_name_in, & field_shape, fill_value, sampling_seq, flag_xyfill, mixing_ratio, dim_bounds, & mdim_sizes, beg_dims, end_dims, cell_methods, errmsg) - type(hist_field_info_t), pointer :: field - character(len=*), intent(in) :: diag_name_in - character(len=*), intent(in) :: std_name_in - character(len=*), intent(in) :: long_name_in - character(len=*), intent(in) :: units_in - character(len=*), intent(in) :: type_in - integer, intent(in) :: decomp_in - integer, intent(in) :: mdim_indices(:) - character(len=*), intent(in) :: acc_type - integer, intent(in) :: num_levels - integer, intent(in) :: field_shape(:) - real(REAL64), intent(in) :: fill_value - character(len=*), optional, intent(in) :: sampling_seq - logical, optional, intent(in) :: flag_xyfill - character(len=*), optional, intent(in) :: mixing_ratio - integer, optional, intent(in) :: dim_bounds(:,:) - integer, optional, intent(in) :: mdim_sizes(:) - integer, optional, intent(in) :: beg_dims(:) - integer, optional, intent(in) :: end_dims(:) - character(len=*), optional, intent(in) :: cell_methods - character(len=*), optional, intent(out) :: errmsg + type(hist_field_info_t), pointer, intent(inout) :: field + character(len=*), intent(in) :: diag_name_in + character(len=*), intent(in) :: std_name_in + character(len=*), intent(in) :: long_name_in + character(len=*), intent(in) :: units_in + character(len=*), intent(in) :: type_in + integer, intent(in) :: decomp_in + integer, intent(in) :: mdim_indices(:) + character(len=*), intent(in) :: acc_type + integer, intent(in) :: num_levels + integer, intent(in) :: field_shape(:) + real(REAL64), intent(in) :: fill_value + character(len=*), optional, intent(in) :: sampling_seq + logical, optional, intent(in) :: flag_xyfill + character(len=*), optional, intent(in) :: mixing_ratio + integer, optional, intent(in) :: dim_bounds(:,:) + integer, optional, intent(in) :: mdim_sizes(:) + integer, optional, intent(in) :: beg_dims(:) + integer, optional, intent(in) :: end_dims(:) + character(len=*), optional, intent(in) :: cell_methods + ! Fortitude: + ! allow(assumed-size-character-intent) + character(len=*), optional, intent(out) :: errmsg if (present(errmsg)) then errmsg = '' @@ -165,8 +167,8 @@ end subroutine hist_field_initialize subroutine hist_get_field(buffer, field) ! Retrieve - class(hist_buffer_t), intent(in) :: buffer - type(hist_field_info_t), pointer :: field + class(hist_buffer_t), intent(in) :: buffer + type(hist_field_info_t), pointer, intent(inout) :: field nullify(field) select type(finfo => buffer%field_info) @@ -350,7 +352,7 @@ subroutine set_dimension_bounds(this, dimbounds, mdim_sizes) integer, intent(in) :: dimbounds(:,:) integer, intent(in) :: mdim_sizes(:) - integer ::idx + integer :: idx allocate(this%field_beg_dims(3)) allocate(this%field_end_dims(3)) @@ -382,8 +384,8 @@ end subroutine set_dimension_bounds subroutine clear_buffers(this, logger) use hist_msg_handler, only: hist_log_messages ! Dummy Argument - class(hist_field_info_t) :: this - type(hist_log_messages), optional :: logger + class(hist_field_info_t), intent(inout) :: this + type(hist_log_messages), optional, intent(inout) :: logger ! Local Variables class(hist_buffer_t), pointer :: next_buf @@ -397,13 +399,13 @@ subroutine clear_buffers(this, logger) end if end do - end subroutine + end subroutine clear_buffers !####################################################################### subroutine finalize_field(this) ! Dummy Argument - type(hist_field_info_t) :: this + type(hist_field_info_t), intent(inout) :: this ! Local Variables class(hist_buffer_t), pointer :: next_buf diff --git a/src/util/hist_msg_handler.F90 b/src/util/hist_msg_handler.F90 index 5185a53..4b85286 100644 --- a/src/util/hist_msg_handler.F90 +++ b/src/util/hist_msg_handler.F90 @@ -30,7 +30,7 @@ module hist_msg_handler type :: hist_log_entry integer :: message_level = ERROR character(len=:), allocatable :: log_message - type(hist_log_entry), pointer :: next => NULL() + type(hist_log_entry), pointer :: next => null() contains final :: finalize_log_entry end type hist_log_entry @@ -41,8 +41,8 @@ module hist_msg_handler logical, private :: alloc_error = .false. integer :: message_level = ERROR integer, private :: max_len = -1 ! no limit - type(hist_log_entry), private, pointer :: log_messages => NULL() - type(hist_log_entry), private, pointer :: tail => NULL() + type(hist_log_entry), private, pointer :: log_messages => null() + type(hist_log_entry), private, pointer :: tail => null() contains procedure :: num_errors => hist_msgs_num_errors procedure :: num_messages => hist_msgs_num_messages @@ -54,20 +54,21 @@ module hist_msg_handler final :: finalize_hist_log_messages end type hist_log_messages - character(len=8) :: MSG_HEAD(ERROR:DEBUG_HIST) = (/ 'ERROR ', 'WARNING ', & - 'INFO ', 'VERBOSE ', 'DEBUG ' /) + character(len=8) :: MSG_HEAD(ERROR:DEBUG_HIST) = ['ERROR ', 'WARNING ', & + 'INFO ', 'VERBOSE ', 'DEBUG '] -CONTAINS +contains !####################################################################### - logical function hist_have_error(errors) + pure function hist_have_error(errors) result(has_error) ! Return .true. iff is present and contains error messages - type(hist_log_messages), optional, intent(inout) :: errors + type(hist_log_messages), optional, intent(in) :: errors + logical :: has_error - hist_have_error = present(errors) - if (hist_have_error) then - hist_have_error = errors%num_errors() > 0 + has_error = present(errors) + if (has_error) then + has_error = errors%num_errors() > 0 end if end function hist_have_error @@ -130,7 +131,7 @@ end subroutine hist_add_alloc_error subroutine finalize_log_entry(this) ! Dummy Argument - type(hist_log_entry) :: this + type(hist_log_entry), intent(inout) :: this ! Local argument type(hist_log_entry), pointer :: next @@ -147,20 +148,22 @@ end subroutine finalize_log_entry !####################################################################### - integer function hist_msgs_num_messages(this) + pure function hist_msgs_num_messages(this) result(num_messages) ! Dummy Argument - class(hist_log_messages) :: this + class(hist_log_messages), intent(in) :: this + integer :: num_messages - hist_msgs_num_messages = this%length + num_messages = this%length end function hist_msgs_num_messages !####################################################################### - integer function hist_msgs_num_errors(this) + pure function hist_msgs_num_errors(this) result(num_errors) ! Dummy Argument - class(hist_log_messages) :: this + class(hist_log_messages), intent(in) :: this + integer :: num_errors - hist_msgs_num_errors = this%error_count + num_errors = this%error_count end function hist_msgs_num_errors !####################################################################### @@ -168,13 +171,13 @@ end function hist_msgs_num_errors subroutine hist_msgs_new_error(this, errstr1, & errint1, errstr2, errint2, errstr3, subname) ! Dummy Arguments - class(hist_log_messages) :: this - character(len=*), intent(in) :: errstr1 - integer, optional, intent(in) :: errint1 - character(len=*), optional, intent(in) :: errstr2 - integer, optional, intent(in) :: errint2 - character(len=*), optional, intent(in) :: errstr3 - character(len=*), optional, intent(in) :: subname + class(hist_log_messages), intent(inout) :: this + character(len=*), intent(in) :: errstr1 + integer, optional, intent(in) :: errint1 + character(len=*), optional, intent(in) :: errstr2 + integer, optional, intent(in) :: errint2 + character(len=*), optional, intent(in) :: errstr3 + character(len=*), optional, intent(in) :: subname call this%new_message(ERROR, errstr1, msgint1=errint1, msgstr2=errstr2, & msgint2=errint2, msgstr3=errstr3, subname=subname) @@ -187,14 +190,14 @@ end subroutine hist_msgs_new_error subroutine hist_msgs_new_message(this, msg_level, msgstr1, & msgint1, msgstr2, msgint2, msgstr3, subname) ! Dummy Arguments - class(hist_log_messages) :: this - integer, intent(in) :: msg_level - character(len=*), intent(in) :: msgstr1 - integer, optional, intent(in) :: msgint1 - character(len=*), optional, intent(in) :: msgstr2 - integer, optional, intent(in) :: msgint2 - character(len=*), optional, intent(in) :: msgstr3 - character(len=*), optional, intent(in) :: subname + class(hist_log_messages), intent(inout) :: this + integer, intent(in) :: msg_level + character(len=*), intent(in) :: msgstr1 + integer, optional, intent(in) :: msgint1 + character(len=*), optional, intent(in) :: msgstr2 + integer, optional, intent(in) :: msgint2 + character(len=*), optional, intent(in) :: msgstr3 + character(len=*), optional, intent(in) :: subname ! Local variables integer, parameter :: num_strs = 3 @@ -234,12 +237,12 @@ subroutine hist_msgs_new_message(this, msg_level, msgstr1, & end if if (present(subname)) then if (msg_lvl == ERROR) then - write(msg_strs(1), '(3a)') " in ", trim(subname), ": " + write(msg_strs(1), '(3a)') ' in ', trim(subname), ': ' else - write(msg_strs(1), '(3a)') "In ", trim(subname), ": " + write(msg_strs(1), '(3a)') 'In ', trim(subname), ': ' end if else - write(msg_strs(1), '(3a)') ": " + write(msg_strs(1), '(3a)') ': ' end if msg_len = msg_len + len_trim(msg_strs(1)) + 1 ! Keep space at end if (present(msgint1)) then @@ -297,11 +300,11 @@ end subroutine hist_msgs_new_message subroutine hist_add_stack_frame(this, msg_level, filename, line, subname) ! Dummy Arguments - class(hist_log_messages) :: this - integer, intent(in) :: msg_level - character(len=*), intent(in) :: filename - integer, intent(in) :: line - character(len=*), optional, intent(in) :: subname + class(hist_log_messages), intent(inout) :: this + integer, intent(in) :: msg_level + character(len=*), intent(in) :: filename + integer, intent(in) :: line + character(len=*), optional, intent(in) :: subname if (present(subname)) then call this%new_message(msg_level, & @@ -319,11 +322,11 @@ end subroutine hist_add_stack_frame subroutine hist_msgs_new_alloc_error(this, fieldname, filename, line, & subname) ! Dummy Arguments - class(hist_log_messages) :: this - character(len=*), intent(in) :: fieldname - character(len=*), intent(in) :: filename - integer, intent(in) :: line - character(len=*), optional, intent(in) :: subname + class(hist_log_messages), intent(inout) :: this + character(len=*), intent(in) :: fieldname + character(len=*), intent(in) :: filename + integer, intent(in) :: line + character(len=*), optional, intent(in) :: subname if (present(subname)) then call this%new_message(ERROR, & @@ -341,7 +344,7 @@ end subroutine hist_msgs_new_alloc_error subroutine hist_msgs_print_log(this, unit, header) ! Dummy Arguments - class(hist_log_messages) :: this + class(hist_log_messages), intent(in) :: this integer, intent(in) :: unit character(len=*), optional, intent(in) :: header @@ -368,7 +371,7 @@ end subroutine hist_msgs_print_log subroutine finalize_hist_log_messages(this) ! Dummy Argument - type(hist_log_messages) :: this + type(hist_log_messages), intent(inout) :: this if (associated(this%log_messages)) then deallocate(this%log_messages)