From 845b714923e78e45f16f8036b71df6373210c188 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Mon, 12 Dec 2022 09:56:12 -0500 Subject: [PATCH 01/13] add routine to modern diag and move first write to routine --- diag_manager/diag_manager.F90 | 4 +- diag_manager/fms_diag_object.F90 | 139 +++++++++++++++++++++++++++++++ 2 files changed, 142 insertions(+), 1 deletion(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index bfcad99001..f7e5b70ede 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -3929,11 +3929,13 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') - WRITE (diag_log_unit,'(777a)') & + if( .not. use_modern_diag) then + WRITE (diag_log_unit,'(777a)') & & 'Module', SEP, 'Field', SEP, 'Long Name', SEP,& & 'Units', SEP, 'Number of Axis', SEP, 'Time Axis', SEP,& & 'Missing Value', SEP, 'Min Value', SEP, 'Max Value', SEP,& & 'AXES LIST' + endif END IF module_is_initialized = .TRUE. diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 3811cfcc0e..a734dfe6c3 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -313,6 +313,10 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax fms_register_diag_field_array=diag_null CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else + if( present(do_not_log)) + if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic=.true., seperator)) + end if fms_register_diag_field_array = this%register( & & module_name, field_name, init_time=init_time, & & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & @@ -355,6 +359,9 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, fms_register_static_field=diag_null CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else + if( present(do_not_log)) + if( .not. do_not_log ) call fms_log_field_info() + end if ! Include static as optional variable to register here fms_register_static_field = this%register( & & module_name, field_name, axes=axes, & @@ -673,4 +680,136 @@ subroutine dump_diag_obj( filename ) call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml") #endif end subroutine + +!> @brief Writes brief diagnostic field info to the log file. +!! @details If the do_diag_field_log namelist parameter is .TRUE., +!! then a line briefly describing diagnostic field is added to +!! the log file. Normally users should not call this subroutine +!! directly, since it is called by register_static_field and +!! register_diag_field if do_not_log is not set to .TRUE.. It is +!! used, however, in LM3 to avoid excessive logs due to the +!! number of fields registered for each of the tile types. LM3 +!! code uses a do_not_log parameter in the registration calls, +!! and subsequently calls this subroutine to log field information +!! under a generic name. +SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic, seperator) + CHARACTER(len=*), INTENT(in) :: module_name !< Module name + CHARACTER(len=*), INTENT(in) :: field_name !< Field name + INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. + CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. + CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. + CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. + LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. + CHARACTER(len=1), optional :: seperator = '|' + + logical, save :: wrote_header = .false. !< set if header was already written + + ! ---- local vars + CHARACTER(len=256) :: lmodule, lfield, lname, lunits + CHARACTER(len=64) :: lmissval, lmin, lmax + CHARACTER(len=8) :: numaxis, timeaxis + CHARACTER(len=256) :: axis_name, axes_list + INTEGER :: i + REAL :: missing_value_use !< Local copy of missing_value + REAL, DIMENSION(2) :: range_use !< Local copy of range + ! return if disabled via nml, we'll just get the nml val from the original call + !IF ( .NOT.do_diag_field_log ) RETURN + IF ( mpp_pe().NE.mpp_root_pe() ) RETURN + + ! Fatal error if range is present and its extent is not 2. + IF ( PRESENT(range) ) THEN + IF ( SIZE(range) .NE. 2 ) THEN + ! extent of range should be 2 + CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL) + END IF + END IF + + lmodule = TRIM(module_name) + lfield = TRIM(field_name) + + IF ( PRESENT(long_name) ) THEN + lname = TRIM(long_name) + ELSE + lname = '' + END IF + + IF ( PRESENT(units) ) THEN + lunits = TRIM(units) + ELSE + lunits = '' + END IF + + WRITE (numaxis,'(i1)') SIZE(axes) + + IF (PRESENT(missing_value)) THEN + IF ( use_cmor ) THEN + WRITE (lmissval,*) CMOR_MISSING_VALUE + ELSE + SELECT TYPE (missing_value) + TYPE IS (real(kind=r4_kind)) + missing_value_use = missing_value + TYPE IS (real(kind=r8_kind)) + missing_value_use = real(missing_value) + CLASS DEFAULT + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + WRITE (lmissval,*) missing_value_use + END IF + ELSE + lmissval = '' + ENDIF + + IF ( PRESENT(range) ) THEN + SELECT TYPE (range) + TYPE IS (real(kind=r4_kind)) + range_use = range + TYPE IS (real(kind=r8_kind)) + range_use = real(range) + CLASS DEFAULT + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + WRITE (lmin,*) range_use(1) + WRITE (lmax,*) range_use(2) + ELSE + lmin = '' + lmax = '' + END IF + + IF ( PRESENT(dynamic) ) THEN + IF (dynamic) THEN + timeaxis = 'T' + ELSE + timeaxis = 'F' + END IF + ELSE + timeaxis = '' + END IF + + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + + if ( .not. wrote_header ) then + WRITE (diag_log_unit,'(777a)') & + & 'Module', sep, 'Field', sep, 'Long Name', sep,& + & 'Units', sep, 'Number of Axis', sep, 'Time Axis', sep,& + & 'Missing Value', sep, 'Min Value', sep, 'Max Value', sep,& + & 'AXES LIST' + wrote_header = .true. + endif + + WRITE (diag_log_unit,'(777a)') & + & TRIM(lmodule), sep, TRIM(lfield), sep, TRIM(lname), sep,& + & TRIM(lunits), sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,& + & TRIM(lmissval), sep, TRIM(lmin), sep, TRIM(lmax), sep,& + & TRIM(axes_list) +END SUBROUTINE log_diag_field_info + end module fms_diag_object_mod From 0e87d6472e0db8794a21773999f7e8fd5edd60f8 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Mon, 12 Dec 2022 13:05:03 -0500 Subject: [PATCH 02/13] add routine for setting separator and correct logic for nml flag --- diag_manager/diag_manager.F90 | 34 +++++++++++++++---- diag_manager/fms_diag_object.F90 | 57 +++++++++++++++++++------------- 2 files changed, 61 insertions(+), 30 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index f7e5b70ede..499aaf80a4 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -436,13 +436,20 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute + logical :: allow_log if (use_modern_diag) then + ! check if logging registered fields, uses arg and nml flag + IF ( PRESENT(do_not_log) ) THEN + allow_log = .NOT.do_not_log + ELSE + allow_log = .TRUE. + END IF register_diag_field_array = fms_diag_object%fms_register_diag_field_array( & & module_name, field_name, axes, init_time, long_name=long_name, & & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & - & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & - & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + & standard_name=standard_name, verbose=verbose, do_not_log=.not.(do_diag_field_log.AND.allow_log), & + & err_msg=err_msg, interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & @@ -479,6 +486,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, !! with this field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute + logical :: allow_log ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN @@ -487,10 +495,16 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF if (use_modern_diag) then + ! check if logging registered fields, uses arg and nml flag + IF ( PRESENT(do_not_log) ) THEN + allow_log = .NOT.do_not_log + ELSE + allow_log = .TRUE. + END IF register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & - & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& - & tile_count=tile_count, area=area, volume=volume, realm=realm) + & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=.not.(do_diag_field_log.AND.allow_log), & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else register_static_field = register_static_field_old(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & @@ -3780,10 +3794,12 @@ END SUBROUTINE closing_file !> @brief Initialize Diagnostics Manager. !! @details Open and read diag_table. Select fields and files for diagnostic output. - SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) + SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg, logfile_separator) INTEGER, OPTIONAL, INTENT(IN) :: diag_model_subset INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + CHARACTER(len=1), INTENT(in), OPTIONAL :: logfile_separator !< character to use as a csv-style data field separator + !! (defaults to '|') CHARACTER(len=*), PARAMETER :: SEP = '|' @@ -3914,7 +3930,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) END IF if (use_modern_diag) then - CALL fms_diag_object%init(diag_subset_output) + CALL fms_diag_object%init(diag_subset_output) endif if (.not. use_modern_diag) then CALL parse_diag_table(DIAG_SUBSET=diag_subset_output, ISTAT=mystat, ERR_MSG=err_msg_local) @@ -3928,13 +3944,17 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN - open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') + open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') if( .not. use_modern_diag) then WRITE (diag_log_unit,'(777a)') & & 'Module', SEP, 'Field', SEP, 'Long Name', SEP,& & 'Units', SEP, 'Number of Axis', SEP, 'Time Axis', SEP,& & 'Missing Value', SEP, 'Min Value', SEP, 'Max Value', SEP,& & 'AXES LIST' + else + if( present(logfile_separator)) then + call fms_diag_object%fms_set_field_log_separator(logfile_separator) + endif endif END IF diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index a734dfe6c3..3f460aae25 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -19,7 +19,8 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & - &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN + &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & + & diag_log_unit, CMOR_MISSING_VALUE, use_cmor USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & & get_ticks_per_second @@ -34,6 +35,7 @@ module fms_diag_object_mod use fms_diag_buffer_mod #endif use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d +use platform_mod implicit none private @@ -70,6 +72,7 @@ module fms_diag_object_mod procedure :: fms_get_diag_field_id_from_name procedure :: fms_get_axis_name_from_id procedure :: fms_diag_send_complete + procedure :: fms_set_field_log_separator #ifdef use_yaml procedure :: get_diag_buffer #endif @@ -77,6 +80,8 @@ module fms_diag_object_mod type (fmsDiagObject_type), target :: fms_diag_object +character(len=1) :: logfile_sep = '|' !< separator used in csv-style log file of registered fields + public :: fms_register_diag_field_obj public :: fms_register_diag_field_scalar public :: fms_register_diag_field_array @@ -313,15 +318,15 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax fms_register_diag_field_array=diag_null CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else - if( present(do_not_log)) - if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic=.true., seperator)) - end if fms_register_diag_field_array = this%register( & & module_name, field_name, init_time=init_time, & & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + if( present(do_not_log)) then + if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range=var_range, dynamic=.true.) + end if #endif end function fms_register_diag_field_array @@ -359,15 +364,16 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, fms_register_static_field=diag_null CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else - if( present(do_not_log)) - if( .not. do_not_log ) call fms_log_field_info() - end if ! Include static as optional variable to register here fms_register_static_field = this%register( & & module_name, field_name, axes=axes, & & longname=long_name, units=units, missing_value=missing_value, varrange=range, & & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, & & static=.true.) + if( present(do_not_log)) then + if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic=.false.) + end if #endif end function fms_register_static_field @@ -693,7 +699,7 @@ subroutine dump_diag_obj( filename ) !! and subsequently calls this subroutine to log field information !! under a generic name. SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic, seperator) + & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs @@ -702,7 +708,6 @@ SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. - CHARACTER(len=1), optional :: seperator = '|' logical, save :: wrote_header = .false. !< set if header was already written @@ -721,8 +726,7 @@ SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL) + CALL mpp_error (FATAL, 'fms_diag_object_mod::fms_log_field_info: extent of range should be 2') END IF END IF @@ -753,8 +757,8 @@ SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r8_kind)) missing_value_use = real(missing_value) CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + CALL mpp_error( FATAL, 'diag_util_mod::log_diag_field_info: The missing_value is not one of the supported'// & + & ' types of real(kind=4) or real(kind=8)') END SELECT WRITE (lmissval,*) missing_value_use END IF @@ -769,7 +773,7 @@ SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r8_kind)) range_use = real(range) CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& + CALL mpp_error('diag_util_mod::log_diag_field_info',& & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT WRITE (lmin,*) range_use(1) @@ -791,25 +795,32 @@ SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& axes_list='' DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) + axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' axes_list = TRIM(axes_list)//TRIM(axis_name) END DO if ( .not. wrote_header ) then WRITE (diag_log_unit,'(777a)') & - & 'Module', sep, 'Field', sep, 'Long Name', sep,& - & 'Units', sep, 'Number of Axis', sep, 'Time Axis', sep,& - & 'Missing Value', sep, 'Min Value', sep, 'Max Value', sep,& + & 'Module', logfile_sep, 'Field', logfile_sep, 'Long Name', logfile_sep,& + & 'Units', logfile_sep, 'Number of Axis', logfile_sep, 'Time Axis', logfile_sep,& + & 'Missing Value', logfile_sep, 'Min Value', logfile_sep, 'Max Value', logfile_sep,& & 'AXES LIST' wrote_header = .true. endif WRITE (diag_log_unit,'(777a)') & - & TRIM(lmodule), sep, TRIM(lfield), sep, TRIM(lname), sep,& - & TRIM(lunits), sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,& - & TRIM(lmissval), sep, TRIM(lmin), sep, TRIM(lmax), sep,& + & TRIM(lmodule), logfile_sep, TRIM(lfield), logfile_sep, TRIM(lname), logfile_sep,& + & TRIM(lunits), logfile_sep, TRIM(numaxis), logfile_sep, TRIM(timeaxis), logfile_sep,& + & TRIM(lmissval), logfile_sep, TRIM(lmin), logfile_sep, TRIM(lmax), logfile_sep,& & TRIM(axes_list) -END SUBROUTINE log_diag_field_info +END SUBROUTINE fms_log_field_info + +!> Staticly sets the separator for the log file if one is passed during initialization +subroutine fms_set_field_log_separator(this, separator) + class(fmsDiagObject_type) :: this + character(len=1), intent(in) :: separator + logfile_sep = separator +end subroutine fms_set_field_log_separator end module fms_diag_object_mod From 4fb2e91b0b780ffb2daa6006196f4612ee6e536c Mon Sep 17 00:00:00 2001 From: rem1776 Date: Tue, 13 Dec 2022 14:23:33 -0500 Subject: [PATCH 03/13] add nml flag to run log routine for modern diag test --- test_fms/diag_manager/test_diag_manager2.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index cf5a3eaa80..7f20103e39 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -646,7 +646,7 @@ _EOF ' - printf "&diag_manager_nml \n use_modern_diag = .true. \n/" | cat > input.nml + printf "&diag_manager_nml \n use_modern_diag = .true. \n do_diag_field_log = .true. \n/" | cat > input.nml cat <<_EOF > diag_table.yaml title: test_diag_manager base_date: 2 1 1 0 0 0 From b53c1a93704afdae46c6de492f048634aba14243 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 21 Dec 2022 12:37:12 -0500 Subject: [PATCH 04/13] remove added routine and rework in order to call from main module --- diag_manager/diag_manager.F90 | 110 ++++++++++++-------- diag_manager/diag_util.F90 | 108 ++++++++++---------- diag_manager/fms_diag_object.F90 | 167 ++----------------------------- 3 files changed, 132 insertions(+), 253 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index d1d689f4ca..429b66c674 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -213,12 +213,12 @@ MODULE diag_manager_mod USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,& & fms_error_handler, check_nml_error, lowercase USE diag_axis_mod, ONLY: diag_axis_init, get_axis_length, get_axis_num, get_domain2d, get_tile_count,& - & diag_axis_add_attribute, axis_compatible_check, CENTER, NORTH, EAST + & diag_axis_add_attribute, axis_compatible_check, CENTER, NORTH, EAST, get_diag_axis_name USE diag_util_mod, ONLY: get_subfield_size, log_diag_field_info, update_bounds,& & check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& & diag_time_inc, find_input_field, init_input_field, init_output_field,& & diag_data_out, write_static, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init + & prepend_attribute, attribute_init, diag_util_init, field_log_separator USE diag_data_mod, ONLY: max_files, CMOR_MISSING_VALUE, DIAG_OTHER, DIAG_OCEAN, DIAG_ALL, EVERY_TIME,& & END_OF_RUN, DIAG_SECONDS, DIAG_MINUTES, DIAG_HOURS, DIAG_DAYS, DIAG_MONTHS, DIAG_YEARS, num_files,& & max_input_fields, max_output_fields, num_output_fields, EMPTY, FILL_VALUE, null_axis_id,& @@ -399,10 +399,20 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, END IF END IF if (use_modern_diag) then + ! check if logging registered fields, uses arg and nml flag + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name,& + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( & & module_name, field_name, init_time, long_name=long_name, units=units, & & missing_value=missing_value, var_range=range, standard_name=standard_name, & - & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm) + & err_msg=err_msg, area=area, volume=volume, realm=realm) else register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, & & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, & @@ -436,19 +446,33 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute - logical :: allow_log + + character(len=256) :: axes_list, axis_name + integer :: i if (use_modern_diag) then - ! check if logging registered fields, uses arg and nml flag - IF ( PRESENT(do_not_log) ) THEN - allow_log = .NOT.do_not_log - ELSE - allow_log = .TRUE. - END IF + + ! check if logging registered fields, uses arg and nml flag + if( do_diag_field_log) then + ! get axis name for output + axes_list='' + DO i = 1, SIZE(axes) + axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, & + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif register_diag_field_array = fms_diag_object%fms_register_diag_field_array( & & module_name, field_name, axes, init_time, long_name=long_name, & & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & - & standard_name=standard_name, verbose=verbose, do_not_log=.not.(do_diag_field_log.AND.allow_log), & + & standard_name=standard_name, verbose=verbose, & & err_msg=err_msg, interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, & @@ -486,8 +510,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, !! with this field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute - logical :: allow_log - + character(len=256) :: axes_list, axis_name + integer :: i ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN ! diag_manager has NOT been initialized @@ -495,15 +519,26 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF if (use_modern_diag) then - ! check if logging registered fields, uses arg and nml flag - IF ( PRESENT(do_not_log) ) THEN - allow_log = .NOT.do_not_log - ELSE - allow_log = .TRUE. - END IF + ! check if logging registered fields, uses arg and nml flag + if( do_diag_field_log) then + ! get axis name for output + axes_list='' + DO i = 1, SIZE(axes) + axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, & + & units, missing_value, range, dynamic=.false.) + else + call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + & missing_value, range, dynamic=.false.) + endif + endif register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & - & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=.not.(do_diag_field_log.AND.allow_log), & + & standard_name=standard_name, dynamic=DYNAMIC, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else register_static_field = register_static_field_old(module_name, field_name, axes, & @@ -772,7 +807,8 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n INTEGER :: tile, file_num LOGICAL :: mask_variant1, dynamic1, allow_log CHARACTER(len=128) :: msg - INTEGER :: domain_type + INTEGER :: domain_type, i + character(len=256) :: axes_list, axis_name ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN @@ -829,12 +865,16 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n END IF END IF - ! Namelist do_diag_field_log is by default false. Thus to log the - ! registration of the data field, but the OPTIONAL parameter - ! do_not_log == .FALSE. and the namelist variable - ! do_diag_field_log == .TRUE.. + ! only writes log if do_diag_field_log is true in the namelist (default false) + ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - CALL log_diag_field_info (module_name, field_name, axes, & + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO + CALL log_diag_field_info (module_name, field_name, axes, axes_list, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF @@ -3794,14 +3834,11 @@ END SUBROUTINE closing_file !> @brief Initialize Diagnostics Manager. !! @details Open and read diag_table. Select fields and files for diagnostic output. - SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg, logfile_separator) + SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) INTEGER, OPTIONAL, INTENT(IN) :: diag_model_subset INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - CHARACTER(len=1), INTENT(in), OPTIONAL :: logfile_separator !< character to use as a csv-style data field separator - !! (defaults to '|') - CHARACTER(len=*), PARAMETER :: SEP = '|' INTEGER, PARAMETER :: FltKind = R4_KIND INTEGER, PARAMETER :: DblKind = R8_KIND @@ -3816,7 +3853,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg, logfile_sepa & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average + & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag,use_clock_average,field_log_separator ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN @@ -3949,17 +3986,6 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg, logfile_sepa ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') - if( .not. use_modern_diag) then - WRITE (diag_log_unit,'(777a)') & - & 'Module', SEP, 'Field', SEP, 'Long Name', SEP,& - & 'Units', SEP, 'Number of Axis', SEP, 'Time Axis', SEP,& - & 'Missing Value', SEP, 'Min Value', SEP, 'Max Value', SEP,& - & 'AXES LIST' - else - if( present(logfile_separator)) then - call fms_diag_object%fms_set_field_log_separator(logfile_separator) - endif - endif END IF module_is_initialized = .TRUE. diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index df83c940b5..f78bf3670c 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -69,7 +69,7 @@ MODULE diag_util_mod USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,& & increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),& & OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==) - USE mpp_mod, ONLY: mpp_npes + USE mpp_mod, ONLY: mpp_npes, mpp_error USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod #ifdef use_netCDF @@ -107,6 +107,9 @@ MODULE diag_util_mod LOGICAL :: module_initialized = .FALSE. + character(len=1), public :: field_log_separator = '|' !< separator used for csv-style log of registered fields + !! set by nml in diag_manager init + CONTAINS @@ -622,114 +625,113 @@ END FUNCTION get_index !! code uses a do_not_log parameter in the registration calls, !! and subsequently calls this subroutine to log field information !! under a generic name. - SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic) + SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs + CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. + logical, save :: wrote_header = .false. !< set if header was already written + ! ---- local vars CHARACTER(len=256) :: lmodule, lfield, lname, lunits CHARACTER(len=64) :: lmissval, lmin, lmax CHARACTER(len=8) :: numaxis, timeaxis - CHARACTER(len=1) :: sep = '|' - CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range - - IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - ! extent of range should be 2 - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'extent of range should be 2', FATAL) - END IF + IF ( SIZE(range) .NE. 2 ) THEN + CALL mpp_error (FATAL, 'fms_diag_object_mod::fms_log_field_info: extent of range should be 2') + END IF END IF lmodule = TRIM(module_name) lfield = TRIM(field_name) IF ( PRESENT(long_name) ) THEN - lname = TRIM(long_name) + lname = TRIM(long_name) ELSE - lname = '' + lname = '' END IF IF ( PRESENT(units) ) THEN - lunits = TRIM(units) + lunits = TRIM(units) ELSE - lunits = '' + lunits = '' END IF WRITE (numaxis,'(i1)') SIZE(axes) IF (PRESENT(missing_value)) THEN - IF ( use_cmor ) THEN - WRITE (lmissval,*) CMOR_MISSING_VALUE - ELSE - SELECT TYPE (missing_value) + IF ( use_cmor ) THEN + WRITE (lmissval,*) CMOR_MISSING_VALUE + ELSE + SELECT TYPE (missing_value) TYPE IS (real(kind=r4_kind)) - missing_value_use = missing_value + missing_value_use = missing_value TYPE IS (real(kind=r8_kind)) - missing_value_use = real(missing_value) + missing_value_use = real(missing_value) CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmissval,*) missing_value_use - END IF + CALL mpp_error( FATAL,'diag_util_mod::log_diag_field_info: The missing_value is not one of the supported'//& + & ' types of real(kind=4) or real(kind=8)') + END SELECT + WRITE (lmissval,*) missing_value_use + END IF ELSE - lmissval = '' + lmissval = '' ENDIF IF ( PRESENT(range) ) THEN - SELECT TYPE (range) - TYPE IS (real(kind=r4_kind)) + SELECT TYPE (range) + TYPE IS (real(kind=r4_kind)) range_use = range - TYPE IS (real(kind=r8_kind)) + TYPE IS (real(kind=r8_kind)) range_use = real(range) - CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info',& - & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmin,*) range_use(1) - WRITE (lmax,*) range_use(2) + CLASS DEFAULT + CALL mpp_error('diag_util_mod::log_diag_field_info',& + & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + WRITE (lmin,*) range_use(1) + WRITE (lmax,*) range_use(2) ELSE - lmin = '' - lmax = '' + lmin = '' + lmax = '' END IF IF ( PRESENT(dynamic) ) THEN - IF (dynamic) THEN + IF (dynamic) THEN timeaxis = 'T' - ELSE + ELSE timeaxis = 'F' - END IF + END IF ELSE - timeaxis = '' + timeaxis = '' END IF - axes_list='' - DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO + if ( .not. wrote_header ) then + WRITE (diag_log_unit,'(777a)') & + & 'Module', field_log_separator,'Field', field_log_separator,'Long Name', field_log_separator,& + & 'Units', field_log_separator,'Number of Axis',field_log_separator,'Time Axis', field_log_separator,& + & 'Missing Value',field_log_separator,'Min Value', field_log_separator,'Max Value', field_log_separator,& + & 'AXES LIST' + wrote_header = .true. + endif - !write (diag_log_unit,'(8(a,a),a)') & WRITE (diag_log_unit,'(777a)') & - & TRIM(lmodule), sep, TRIM(lfield), sep, TRIM(lname), sep,& - & TRIM(lunits), sep, TRIM(numaxis), sep, TRIM(timeaxis), sep,& - & TRIM(lmissval), sep, TRIM(lmin), sep, TRIM(lmax), sep,& - & TRIM(axes_list) + & TRIM(lmodule), field_log_separator, TRIM(lfield), field_log_separator, TRIM(lname), field_log_separator,& + & TRIM(lunits), field_log_separator, TRIM(numaxis), field_log_separator, TRIM(timeaxis), field_log_separator,& + & TRIM(lmissval), field_log_separator, TRIM(lmin), field_log_separator, TRIM(lmax), field_log_separator,& + & TRIM(axes_list) END SUBROUTINE log_diag_field_info !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 3092ae16f7..2f3b8f066d 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -72,7 +72,6 @@ module fms_diag_object_mod procedure :: fms_get_diag_field_id_from_name procedure :: fms_get_axis_name_from_id procedure :: fms_diag_send_complete - procedure :: fms_set_field_log_separator #ifdef use_yaml procedure :: get_diag_buffer #endif @@ -80,8 +79,6 @@ module fms_diag_object_mod type (fmsDiagObject_type), target :: fms_diag_object -character(len=1) :: logfile_sep = '|' !< separator used in csv-style log file of registered fields - public :: fms_register_diag_field_obj public :: fms_register_diag_field_scalar public :: fms_register_diag_field_array @@ -158,7 +155,7 @@ end subroutine fms_diag_object_end integer function fms_register_diag_field_obj & (this, modname, varname, axes, init_time, & longname, units, missing_value, varRange, mask_variant, standname, & - do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static) + err_msg, interp_method, tile_count, area, volume, realm, static) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name @@ -171,7 +168,6 @@ integer function fms_register_diag_field_obj & class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. @@ -214,7 +210,8 @@ integer function fms_register_diag_field_obj & !> Register the data for the field call fieldptr%register(modname, varname, diag_field_indices, fms_diag_object%diag_axis, & axes, longname, units, missing_value, varRange, mask_variant, standname, & - do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static) + err_msg=err_msg, interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, & + static=static) !> Get the file IDs from the field indicies from the yaml file_ids = get_diag_files_id(diag_field_indices) !> Add the axis information, initial time, and field IDs to the files @@ -258,7 +255,7 @@ end function fms_register_diag_field_obj !> @brief Registers a scalar field !! @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, & - & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& + & long_name, units, missing_value, var_range, standard_name, err_msg,& & area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from @@ -269,7 +266,6 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field @@ -281,7 +277,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in fms_register_diag_field_scalar = this%register(& & module_name, field_name, init_time=init_time, & & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & standname=standard_name, err_msg=err_msg, & & area=area, volume=volume, realm=realm) #endif end function fms_register_diag_field_scalar @@ -290,7 +286,7 @@ end function fms_register_diag_field_scalar !> @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, & & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& - & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) + & err_msg, interp_method, tile_count, area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field @@ -303,7 +299,6 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. @@ -321,19 +316,15 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax fms_register_diag_field_array = this%register( & & module_name, field_name, init_time=init_time, & & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & + & mask_variant=mask_variant, standname=standard_name, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) - if( present(do_not_log)) then - if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range=var_range, dynamic=.true.) - end if #endif end function fms_register_diag_field_array !> @brief Return field index for subsequent call to send_data. !! @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& + & missing_value, range, mask_variant, standard_name, DYNAMIC, interp_method,& & tile_count, area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on @@ -347,7 +338,6 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has !! a mask variant LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing !! Valid options are "conserve_order1", @@ -368,12 +358,8 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, fms_register_static_field = this%register( & & module_name, field_name, axes=axes, & & longname=long_name, units=units, missing_value=missing_value, varrange=range, & - & standname=standard_name, do_not_log=do_not_log, area=area, volume=volume, realm=realm, & + & standname=standard_name, area=area, volume=volume, realm=realm, & & static=.true.) - if( present(do_not_log)) then - if( .not. do_not_log ) call fms_log_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic=.false.) - end if #endif end function fms_register_static_field @@ -689,140 +675,5 @@ subroutine dump_diag_obj( filename ) #endif end subroutine -!> @brief Writes brief diagnostic field info to the log file. -!! @details If the do_diag_field_log namelist parameter is .TRUE., -!! then a line briefly describing diagnostic field is added to -!! the log file. Normally users should not call this subroutine -!! directly, since it is called by register_static_field and -!! register_diag_field if do_not_log is not set to .TRUE.. It is -!! used, however, in LM3 to avoid excessive logs due to the -!! number of fields registered for each of the tile types. LM3 -!! code uses a do_not_log parameter in the registration calls, -!! and subsequently calls this subroutine to log field information -!! under a generic name. -SUBROUTINE fms_log_field_info(module_name, field_name, axes, long_name, units,& - & missing_value, range, dynamic ) - CHARACTER(len=*), INTENT(in) :: module_name !< Module name - CHARACTER(len=*), INTENT(in) :: field_name !< Field name - INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. - CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. - CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. - LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. - - logical, save :: wrote_header = .false. !< set if header was already written - - ! ---- local vars - CHARACTER(len=256) :: lmodule, lfield, lname, lunits - CHARACTER(len=64) :: lmissval, lmin, lmax - CHARACTER(len=8) :: numaxis, timeaxis - CHARACTER(len=256) :: axis_name, axes_list - INTEGER :: i - REAL :: missing_value_use !< Local copy of missing_value - REAL, DIMENSION(2) :: range_use !< Local copy of range - ! return if disabled via nml, we'll just get the nml val from the original call - !IF ( .NOT.do_diag_field_log ) RETURN - IF ( mpp_pe().NE.mpp_root_pe() ) RETURN - - ! Fatal error if range is present and its extent is not 2. - IF ( PRESENT(range) ) THEN - IF ( SIZE(range) .NE. 2 ) THEN - CALL mpp_error (FATAL, 'fms_diag_object_mod::fms_log_field_info: extent of range should be 2') - END IF - END IF - - lmodule = TRIM(module_name) - lfield = TRIM(field_name) - - IF ( PRESENT(long_name) ) THEN - lname = TRIM(long_name) - ELSE - lname = '' - END IF - - IF ( PRESENT(units) ) THEN - lunits = TRIM(units) - ELSE - lunits = '' - END IF - - WRITE (numaxis,'(i1)') SIZE(axes) - - IF (PRESENT(missing_value)) THEN - IF ( use_cmor ) THEN - WRITE (lmissval,*) CMOR_MISSING_VALUE - ELSE - SELECT TYPE (missing_value) - TYPE IS (real(kind=r4_kind)) - missing_value_use = missing_value - TYPE IS (real(kind=r8_kind)) - missing_value_use = real(missing_value) - CLASS DEFAULT - CALL mpp_error( FATAL, 'diag_util_mod::log_diag_field_info: The missing_value is not one of the supported'// & - & ' types of real(kind=4) or real(kind=8)') - END SELECT - WRITE (lmissval,*) missing_value_use - END IF - ELSE - lmissval = '' - ENDIF - - IF ( PRESENT(range) ) THEN - SELECT TYPE (range) - TYPE IS (real(kind=r4_kind)) - range_use = range - TYPE IS (real(kind=r8_kind)) - range_use = real(range) - CLASS DEFAULT - CALL mpp_error('diag_util_mod::log_diag_field_info',& - & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - WRITE (lmin,*) range_use(1) - WRITE (lmax,*) range_use(2) - ELSE - lmin = '' - lmax = '' - END IF - - IF ( PRESENT(dynamic) ) THEN - IF (dynamic) THEN - timeaxis = 'T' - ELSE - timeaxis = 'F' - END IF - ELSE - timeaxis = '' - END IF - - axes_list='' - DO i = 1, SIZE(axes) - axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - - if ( .not. wrote_header ) then - WRITE (diag_log_unit,'(777a)') & - & 'Module', logfile_sep, 'Field', logfile_sep, 'Long Name', logfile_sep,& - & 'Units', logfile_sep, 'Number of Axis', logfile_sep, 'Time Axis', logfile_sep,& - & 'Missing Value', logfile_sep, 'Min Value', logfile_sep, 'Max Value', logfile_sep,& - & 'AXES LIST' - wrote_header = .true. - endif - - WRITE (diag_log_unit,'(777a)') & - & TRIM(lmodule), logfile_sep, TRIM(lfield), logfile_sep, TRIM(lname), logfile_sep,& - & TRIM(lunits), logfile_sep, TRIM(numaxis), logfile_sep, TRIM(timeaxis), logfile_sep,& - & TRIM(lmissval), logfile_sep, TRIM(lmin), logfile_sep, TRIM(lmax), logfile_sep,& - & TRIM(axes_list) -END SUBROUTINE fms_log_field_info - -!> Staticly sets the separator for the log file if one is passed during initialization -subroutine fms_set_field_log_separator(this, separator) - class(fmsDiagObject_type) :: this - character(len=1), intent(in) :: separator - logfile_sep = separator -end subroutine fms_set_field_log_separator end module fms_diag_object_mod From 1d04b51bc231fcd9576fbcb6cb25aafb48221e42 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 28 Dec 2022 10:26:11 -0500 Subject: [PATCH 05/13] whitespace --- diag_manager/diag_util.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index f78bf3670c..3684f3b925 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -630,7 +630,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names + CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. From 83b87068bb410390327e89e3594b1f9a90c443ca Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 25 Jan 2023 10:45:05 -0500 Subject: [PATCH 06/13] check read freq amd value set in obj --- diag_manager/fms_diag_yaml.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index f685d6c8ed..10081b460c 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -483,6 +483,7 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", buffer) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", freq_buffer) + print *, "read freq:", freq_buffer call set_file_freq(fileobj, freq_buffer, buffer) deallocate(freq_buffer, buffer) @@ -681,6 +682,8 @@ subroutine set_file_freq(fileobj, file_freq, file_frequnit) read(file_freq, *, iostat=err_unit) fileobj%file_freq read(file_frequnit, *, iostat=err_unit) file_freq_units + print *, "set file freq:", fileobj%file_fname + do i = 1, MAX_FREQ if (fileobj%file_freq(i) >= -1) then if (trim(file_freq_units(i)) .eq. "") & From 01b2bc90b58c5a243500a3d96f7d0a22d7c915e5 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Wed, 25 Jan 2023 10:48:24 -0500 Subject: [PATCH 07/13] Revert "whitespace" This reverts commit 1d04b51bc231fcd9576fbcb6cb25aafb48221e42. --- diag_manager/diag_util.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 3684f3b925..f78bf3670c 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -630,7 +630,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names + CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. From d27674ec651217f421e1640609b70612c44d4596 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 7 Apr 2023 13:51:12 -0400 Subject: [PATCH 08/13] revert unneeded code changes with current dmUpdate --- diag_manager/diag_manager.F90 | 311 ++++++++++++++------ diag_manager/diag_util.F90 | 491 ++++++++++++++++++++----------- diag_manager/fms_diag_object.F90 | 283 ++++++++++++++---- 3 files changed, 762 insertions(+), 323 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 429b66c674..ad8795aca4 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -201,6 +201,9 @@ MODULE diag_manager_mod ! The values are defined as GLO_REG_VAL (-999) and GLO_REG_VAL_ALT ! (-1) in diag_data_mod. ! + ! + ! Set to true, diag_manager uses mpp_io. Default is fms2_io. + ! ! USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& @@ -229,9 +232,9 @@ MODULE diag_manager_mod & diag_log_unit, time_unit_list, pelist_name, max_axes, module_is_initialized, max_num_axis_sets,& & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,& & max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,& - & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time,diag_data_init,& - & use_modern_diag, use_clock_average, diag_null - + & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,& + & use_mpp_io, use_refactored_send, & + & use_modern_diag, use_clock_average, diag_null, pack_size_str USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att @@ -239,6 +242,9 @@ MODULE diag_manager_mod use fms_diag_object_mod, only:fms_diag_object USE constants_mod, ONLY: SECONDS_PER_DAY + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & + & fieldbuff_copy_fieldvals #ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR @@ -372,6 +378,7 @@ MODULE diag_manager_mod !> @addtogroup diag_manager_mod !> @{ CONTAINS + !> @brief Registers a scalar field !! @return field index for subsequent call to send_data. INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, & @@ -399,20 +406,19 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, END IF END IF if (use_modern_diag) then - ! check if logging registered fields, uses arg and nml flag - if( do_diag_field_log) then - if ( PRESENT(do_not_log) ) THEN - if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name,& - & units, missing_value, range, dynamic=.true.) - else - call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name, units,& - & missing_value, range, dynamic=.true.) - endif - endif + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name,& + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif register_diag_field_scalar = fms_diag_object%fms_register_diag_field_scalar( & & module_name, field_name, init_time, long_name=long_name, units=units, & & missing_value=missing_value, var_range=range, standard_name=standard_name, & - & err_msg=err_msg, area=area, volume=volume, realm=realm) + & do_not_log=do_not_log, err_msg=err_msg, area=area, volume=volume, realm=realm) else register_diag_field_scalar = register_diag_field_scalar_old(module_name, field_name, init_time, & & long_name=long_name, units=units, missing_value=missing_value, range=range, standard_name=standard_name, & @@ -447,33 +453,21 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the modeling_realm attribute - character(len=256) :: axes_list, axis_name - integer :: i - if (use_modern_diag) then - - ! check if logging registered fields, uses arg and nml flag - if( do_diag_field_log) then - ! get axis name for output - axes_list='' - DO i = 1, SIZE(axes) - axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - if ( PRESENT(do_not_log) ) THEN - if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, & - & units, missing_value, range, dynamic=.true.) - else - call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& - & missing_value, range, dynamic=.true.) - endif - endif + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, "", long_name,& + & units, missing_value, range, dynamic=.true.) + else + call log_diag_field_info(module_name, field_name, axes, "", long_name, units,& + & missing_value, range, dynamic=.true.) + endif + endif register_diag_field_array = fms_diag_object%fms_register_diag_field_array( & & module_name, field_name, axes, init_time, long_name=long_name, & & units=units, missing_value=missing_value, var_range=range, mask_variant=mask_variant, & - & standard_name=standard_name, verbose=verbose, & - & err_msg=err_msg, interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + & standard_name=standard_name, verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) else register_diag_field_array = register_diag_field_array_old(module_name, field_name, axes, init_time, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & @@ -510,8 +504,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, !! with this field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the !! modeling_realm attribute - character(len=256) :: axes_list, axis_name - integer :: i + ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN ! diag_manager has NOT been initialized @@ -519,27 +512,10 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF if (use_modern_diag) then - ! check if logging registered fields, uses arg and nml flag - if( do_diag_field_log) then - ! get axis name for output - axes_list='' - DO i = 1, SIZE(axes) - axis_name = fms_diag_object%fms_get_axis_name_from_id(axes(i)) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - if ( PRESENT(do_not_log) ) THEN - if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, & - & units, missing_value, range, dynamic=.false.) - else - call log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& - & missing_value, range, dynamic=.false.) - endif - endif register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & - & standard_name=standard_name, dynamic=DYNAMIC, & - & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) + & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& + & tile_count=tile_count, area=area, volume=volume, realm=realm) else register_static_field = register_static_field_old(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & @@ -581,22 +557,20 @@ INTEGER FUNCTION register_diag_field_scalar_old(module_name, field_name, init_ti END IF END FUNCTION register_diag_field_scalar_old -INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, & + !> @brief Registers an array field + !> @return field index for subsequent call to send_data. + INTEGER FUNCTION register_diag_field_array_old(module_name, field_name, axes, init_time, & & long_name, units, missing_value, range, mask_variant, standard_name, verbose,& & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) - CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from - CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field - INTEGER, INTENT(in) :: axes(:) !< Ids corresponding to the variable axis - TYPE(time_type), OPTIONAL, INTENT(in) :: init_time !< Time to start writing data from - CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long_name to add as a variable attribute - CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Units to add as a variable_attribute - CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute - CLASS(*), OPTIONAL, INTENT(in) :: range(:) !< Range to add a variable attribute - LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant - CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file - LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information - LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged - CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call + CHARACTER(len=*), INTENT(in) :: module_name, field_name + INTEGER, INTENT(in) :: axes(:) + TYPE(time_type), INTENT(in) :: init_time + CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name, units, standard_name + CLASS(*), OPTIONAL, INTENT(in) :: missing_value + CLASS(*), DIMENSION(:), OPTIONAL, INTENT(in) :: range + LOGICAL, OPTIONAL, INTENT(in) :: mask_variant,verbose + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged + CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. !! Valid options are "conserve_order1", @@ -808,7 +782,7 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n LOGICAL :: mask_variant1, dynamic1, allow_log CHARACTER(len=128) :: msg INTEGER :: domain_type, i - character(len=256) :: axes_list, axis_name + character(len=256) :: axis_name ! Fatal error if the module has not been initialized. IF ( .NOT.module_is_initialized ) THEN @@ -868,13 +842,7 @@ INTEGER FUNCTION register_static_field_old(module_name, field_name, axes, long_n ! only writes log if do_diag_field_log is true in the namelist (default false) ! if do_diag_field_log is true and do_not_log arg is present as well, it will only print if do_not_log = false IF ( do_diag_field_log.AND.allow_log ) THEN - axes_list='' - DO i = 1, SIZE(axes) - CALL get_diag_axis_name(axes(i),axis_name) - IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' - axes_list = TRIM(axes_list)//TRIM(axis_name) - END DO - CALL log_diag_field_info (module_name, field_name, axes, axes_list, & + CALL log_diag_field_info (module_name, field_name, axes, & & long_name, units, missing_value=missing_value, range=range, & & DYNAMIC=dynamic1) END IF @@ -1495,7 +1463,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) + send_data_0d = diag_send_data(diag_field_id, field_out, time, err_msg=err_msg) END FUNCTION send_data_0d !> @return true if send is successful @@ -1550,18 +1518,18 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, mask=mask_out,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, mask=mask_out,& & weight=weight, err_msg=err_msg) END IF ELSE IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN - send_data_1d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& + send_data_1d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_1d = send_data_3d(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) + send_data_1d = diag_send_data(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) END IF END IF END FUNCTION send_data_1d @@ -1618,10 +1586,10 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& - & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + & mask=mask_out, ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) ELSE - send_data_2d = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& + send_data_2d = diag_send_data(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) END IF END FUNCTION send_data_2d @@ -1638,6 +1606,34 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + if (present(mask) .and. present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, & + err_msg=err_msg) + elseif (present(rmask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + rmask=rmask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + elseif (present(mask)) then + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + mask=mask, ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + else + send_data_3d = diag_send_data(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, ks_in=ks_in, & + ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) + endif + END FUNCTION send_data_3d + + !> @return true if send is successful + LOGICAL FUNCTION diag_send_data(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + CLASS(*), DIMENSION(:,:,:), INTENT(in),TARGET,CONTIGUOUS :: field + CLASS(*), INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + REAL :: weight1 REAL :: missvalue INTEGER :: pow_value @@ -1670,13 +1666,23 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CHARACTER(len=128) :: error_string, error_string1 REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + class(*), pointer, dimension(:,:,:,:) :: field_modern !< i8 4d remapped pointer + REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask + REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! Set up array lengths for remapping + field_modern => null() + ie = SIZE(field,1) + je = SIZE(field,2) + ke = SIZE(field,3) + field_modern(1:ie,1:je,1:ke,1:1) => field + endif SELECT TYPE (field) TYPE IS (real(kind=r4_kind)) field_out = field @@ -1707,9 +1720,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & field_out = real(field) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + & 'The field is not one of the supported types (real(kind=4) or real(kind=8)). '//& + & 'If using an integer, please set use_modern_diag=.t. in the diag_manager_nml.', FATAL) END SELECT - + ! Split old and modern2023 here + modern_if: iF (use_modern_diag) then + diag_send_data = fms_diag_object%fms_diag_accept_data(diag_field_id, field_modern, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + nullify (field_modern) + elSE ! modern_if ! oor_mask is only used for checking out of range values. ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) IF ( status .NE. 0 ) THEN @@ -1724,12 +1743,18 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & oor_mask = .TRUE. END IF + rmask_ptr_r4 => null() + rmask_ptr_r8 => null() IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r4_kind + rmask_ptr_r4 => rmask TYPE IS (real(kind=r8_kind)) WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r8_kind + rmask_ptr_r8 => rmask CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -2059,6 +2084,85 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + IF (USE_REFACTORED_SEND) THEN + ALLOCATE( ofield_index_cfg ) + CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, & + & hi, hj, f1, f2, f3, f4) + + ALLOCATE( ofield_cfg ) + CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq) + + IF ( average ) THEN + !!TODO (Future work): the copy that is filed_out should not be necessary + mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& + & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & + & mask, weight1 ,missvalue, & + & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& + & input_fields(diag_field_id)%issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + ELSE !!NOT AVERAGE + mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & + & output_fields(out_num)%count_0d(sample), & + & mask, missvalue, l_start, l_end, err_msg, err_msg_local) + IF (mf_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + + IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + !!TODO: (Discusssion) One of the calls below will not compile depending + !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*) + !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful. + !! The option used for now is that the original code to copy missing values is + !! is used at the end of this procedure. + !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + ! SELECT TYPE (rmask) + ! TYPE IS (real(kind=r4_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r4, rmask_threshold, missvalue) + ! TYPE IS (real(kind=r8_kind)) + ! call fieldbuff_copy_missvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r8, rmask_threshold, missvalue) + ! CLASS DEFAULT + ! CALL error_mesg ('diag_manager_mod::send_data_3d',& + ! & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + ! END SELECT + !END IF + + IF(ALLOCATED(ofield_index_cfg)) THEN + DEALLOCATE(ofield_index_cfg) + ENDIF + IF(ALLOCATED(ofield_cfg)) THEN + DEALLOCATE(ofield_cfg) + ENDIF + + ELSE !! END USE_REFACTORED_SEND; Don''t use CYCLE option. + ! Take care of submitted field data IF ( average ) THEN IF ( input_fields(diag_field_id)%mask_variant ) THEN @@ -3205,6 +3309,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + END IF !! END OF IS_USE_REFACTORED SEND + ! If rmask and missing value present, then insert missing value IF ( PRESENT(rmask) .AND. missvalue_present ) THEN IF ( need_compute ) THEN @@ -3302,7 +3408,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(field_out) DEALLOCATE(oor_mask) - END FUNCTION send_data_3d + endIF modern_if + END FUNCTION diag_send_data !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) @@ -3754,7 +3861,7 @@ SUBROUTINE diag_manager_end(time) if (allocated(fnum_for_domain)) deallocate(fnum_for_domain) if (use_modern_diag) then - call fms_diag_object%diag_end() + call fms_diag_object%diag_end(time) endif END SUBROUTINE diag_manager_end @@ -3839,6 +3946,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) INTEGER, DIMENSION(6), OPTIONAL, INTENT(IN) :: time_init !< Model time diag_manager initialized CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + CHARACTER(len=*), PARAMETER :: SEP = '|' INTEGER, PARAMETER :: FltKind = R4_KIND INTEGER, PARAMETER :: DblKind = R8_KIND @@ -3853,7 +3961,8 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag,use_clock_average,field_log_separator + & max_file_attributes, max_axis_attributes, prepend_date, use_modern_diag, use_clock_average, & + & field_log_separator, use_refactored_send ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN @@ -3868,7 +3977,11 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! Determine pack_size from how many bytes a real value has (how compiled) pack_size = SIZE(TRANSFER(0.0_DblKind, (/0.0, 0.0, 0.0, 0.0/))) - IF ( pack_size.NE.1 .AND. pack_size.NE.2 ) THEN + IF (pack_size .EQ. 1) then + pack_size_str = "double" + else if (pack_size .EQ. 2) then + pack_size_str = "float" + else IF ( fms_error_handler('diag_manager_mod::diag_manager_init', 'unknown pack_size. Must be 1, or 2.', & & err_msg) ) RETURN END IF @@ -3986,6 +4099,12 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) ! open diag field log file IF ( do_diag_field_log.AND.mpp_pe().EQ.mpp_root_pe() ) THEN open(newunit=diag_log_unit, file='diag_field_log.out', action='WRITE') + WRITE (diag_log_unit,'(777a)') & + & 'Module', FIELD_LOG_SEPARATOR, 'Field', FIELD_LOG_SEPARATOR, & + & 'Long Name', FIELD_LOG_SEPARATOR, 'Units', FIELD_LOG_SEPARATOR, & + & 'Number of Axis', FIELD_LOG_SEPARATOR, 'Time Axis', FIELD_LOG_SEPARATOR, & + & 'Missing Value', FIELD_LOG_SEPARATOR, 'Min Value', FIELD_LOG_SEPARATOR, & + & 'Max Value', FIELD_LOG_SEPARATOR, 'AXES LIST' END IF module_is_initialized = .TRUE. diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index f78bf3670c..2ca566b97d 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -69,9 +69,10 @@ MODULE diag_util_mod USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,& & increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),& & OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==) - USE mpp_mod, ONLY: mpp_npes, mpp_error + USE mpp_mod, ONLY: mpp_npes USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type #ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR #endif @@ -82,7 +83,10 @@ MODULE diag_util_mod & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,& & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,& & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& - & prepend_attribute, attribute_init, diag_util_init + & prepend_attribute, attribute_init, diag_util_init,& + & fms_diag_check_out_of_bounds, & + & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static,& + & get_time_string !> @brief Prepend a value to a string attribute in the output field or output file. @@ -99,6 +103,12 @@ MODULE diag_util_mod MODULE PROCEDURE attribute_init_file END INTERFACE attribute_init + INTERFACE fms_diag_check_out_of_bounds + module procedure fms_diag_check_out_of_bounds_r4 + module procedure fms_diag_check_out_of_bounds_r8 + END INTERFACE fms_diag_check_out_of_bounds + + !> @addtogroup diag_util_mod !> @{ @@ -625,33 +635,34 @@ END FUNCTION get_index !! code uses a do_not_log parameter in the registration calls, !! and subsequently calls this subroutine to log field information !! under a generic name. - SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_name, units,& + SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & missing_value, range, dynamic ) CHARACTER(len=*), INTENT(in) :: module_name !< Module name CHARACTER(len=*), INTENT(in) :: field_name !< Field name INTEGER, DIMENSION(:), INTENT(in) :: axes !< Axis IDs - CHARACTER(len=*), INTENT(in) :: axes_list !< Comma seperated list of axes names CHARACTER(len=*), OPTIONAL, INTENT(in) :: long_name !< Long name for field. CHARACTER(len=*), OPTIONAL, INTENT(in) :: units !< Unit of field. CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value value. CLASS(*), DIMENSION(:), OPTIONAL, INTENT(IN) :: range !< Valid range of values for field. LOGICAL, OPTIONAL, INTENT(in) :: dynamic !< .TRUE. if field is not static. - logical, save :: wrote_header = .false. !< set if header was already written - ! ---- local vars CHARACTER(len=256) :: lmodule, lfield, lname, lunits CHARACTER(len=64) :: lmissval, lmin, lmax CHARACTER(len=8) :: numaxis, timeaxis + CHARACTER(len=1) :: sep = '|' + CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i REAL :: missing_value_use !< Local copy of missing_value REAL, DIMENSION(2) :: range_use !< Local copy of range + + IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN ! Fatal error if range is present and its extent is not 2. IF ( PRESENT(range) ) THEN IF ( SIZE(range) .NE. 2 ) THEN - CALL mpp_error (FATAL, 'fms_diag_object_mod::fms_log_field_info: extent of range should be 2') + CALL error_mesg('diag_util_mod::fms_log_field_info', 'extent of range should be 2', FATAL) END IF END IF @@ -682,8 +693,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na TYPE IS (real(kind=r8_kind)) missing_value_use = real(missing_value) CLASS DEFAULT - CALL mpp_error( FATAL,'diag_util_mod::log_diag_field_info: The missing_value is not one of the supported'//& - & ' types of real(kind=4) or real(kind=8)') + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT WRITE (lmissval,*) missing_value_use END IF @@ -698,7 +709,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na TYPE IS (real(kind=r8_kind)) range_use = real(range) CLASS DEFAULT - CALL mpp_error('diag_util_mod::log_diag_field_info',& + CALL error_mesg ('diag_util_mod::log_diag_field_info',& & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT WRITE (lmin,*) range_use(1) @@ -718,14 +729,12 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na timeaxis = '' END IF - if ( .not. wrote_header ) then - WRITE (diag_log_unit,'(777a)') & - & 'Module', field_log_separator,'Field', field_log_separator,'Long Name', field_log_separator,& - & 'Units', field_log_separator,'Number of Axis',field_log_separator,'Time Axis', field_log_separator,& - & 'Missing Value',field_log_separator,'Min Value', field_log_separator,'Max Value', field_log_separator,& - & 'AXES LIST' - wrote_header = .true. - endif + axes_list='' + DO i = 1, SIZE(axes) + CALL get_diag_axis_name(axes(i),axis_name) + IF ( TRIM(axes_list) /= '' ) axes_list = TRIM(axes_list)//',' + axes_list = TRIM(axes_list)//TRIM(axis_name) + END DO WRITE (diag_log_unit,'(777a)') & & TRIM(lmodule), field_log_separator, TRIM(lfield), field_log_separator, TRIM(lname), field_log_separator,& @@ -734,7 +743,10 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, axes_list, long_na & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). + + + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) + !! with the six specified bounds values. SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. @@ -743,173 +755,312 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - - output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i) - output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i) - output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j) - output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j) - output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k) - output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k) + CALL output_fields(out_num)%buff_bounds%update_bounds & + & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds - !> @brief Checks if the array indices for output_fields(out_num) are outside the - !! output_fields(out_num)%buffer upper - !! and lower bounds. - SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty - !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - - IF ( output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = 'module/output_field='//TRIM(error_string1)//& - & ' Bounds of buffer exceeded. '//TRIM(error_string2) - ! imax, imin, etc need to be reset in case the program is not terminated. - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - ELSE - err_msg = '' - END IF - END SUBROUTINE check_out_of_bounds - !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if - !! output_fields(out_num)%Time_of_prev_field_data is not - !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. - !! An empty error string indicates the x, y, and z indices are - !! equal to the buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - LOGICAL :: do_check - - err_msg = '' + !> @brief Compares the bounding indices of an array specified in "current_bounds" +!! to the corresponding lower and upper bounds specified in "bounds" +!! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. +!! If any compariosn function returns true, then, after filling error_str, this routine also returns +!! true. The suplied comparison functions should return true for errors : for indices out of bounds, +!! or indices are not equal when expected to be equal. +LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. + INTERFACE + LOGICAL FUNCTION lowerb_comp(a , b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION lowerb_comp + END INTERFACE + + !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer. + INTERFACE + LOGICAL FUNCTION upperb_comp(a, b) + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. + END FUNCTION upperb_comp + END INTERFACE + + compare_buffer_bounds_to_size = .FALSE. + + IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. & + upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.& + lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.& + upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.& + lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.& + upperb_comp( bounds%get_kmax() , current_bounds%get_kmax())) THEN + compare_buffer_bounds_to_size = .TRUE. + error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' + WRITE(error_str(15:17),'(i3)') current_bounds%get_imin() + WRITE(error_str(19:21),'(i3)') current_bounds%get_imax() + WRITE(error_str(23:25),'(i3)') current_bounds%get_jmin() + WRITE(error_str(27:29),'(i3)') current_bounds%get_jmax() + WRITE(error_str(31:33),'(i3)') current_bounds%get_kmin() + WRITE(error_str(35:37),'(i3)') current_bounds%get_kmax() + WRITE(error_str(54:56),'(i3)') bounds%get_imin() + WRITE(error_str(58:60),'(i3)') bounds%get_imax() + WRITE(error_str(62:64),'(i3)') bounds%get_jmin() + WRITE(error_str(66:68),'(i3)') bounds%get_jmax() + WRITE(error_str(70:72),'(i3)') bounds%get_kmin() + WRITE(error_str(74:76),'(i3)') bounds%get_kmax() + ELSE + compare_buffer_bounds_to_size = .FALSE. + error_str = '' + END IF +END FUNCTION compare_buffer_bounds_to_size + +!> @brief return true iff a @brief return true iff a>b. +LOGICAL FUNCTION a_greaterthan_b(a, b) + INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. + a_greaterthan_b = A > B +END FUNCTION a_greaterthan_b + +!> @brief return true iff a /= b +LOGICAL FUNCTION a_noteq_b(a, b) +INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. +INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. +a_noteq_b = a /= b +END FUNCTION a_noteq_b - ! Check bounds only when the value of Time changes. When windows are used, - ! a change in Time indicates that a new loop through the windows has begun, - ! so a check of the previous loop can be done. - IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN - do_check = .FALSE. + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + associate (buff_bounds => output_fields(out_num)%buff_bounds) + + CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ELSE - IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN - ! It may or may not be OK to check, I don't know how to tell. - ! Check will be done on subsequent calls anyway. - do_check = .FALSE. - ELSE - do_check = .TRUE. - END IF - output_fields(out_num)%Time_of_prev_field_data = Time + err_msg = '' END IF + end associate +END SUBROUTINE check_out_of_bounds + + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds + + CALL array_bounds%reset_bounds_from_array_5D(ofb) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + call bounds%reset(VERY_LARGE_AXIS_LENGTH,0) + ELSE + err_msg = '' + END IF +END SUBROUTINE fms_diag_check_out_of_bounds_r4 + + !> @brief Checks if the array indices for output_field buffer (ofb) are outside the + !! are outside the bounding box (bounds). + !! If there is an error then error message will be filled. + +SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fmsDiagIbounds_type) :: array_bounds ! @brief Checks that array indices specified in the bounding box "current_bounds" +!! are identical to those in the bounding box "bounds" match exactly. The check +!! occurs only when the time changed. +!! If there is an error then error message will be filled. +SUBROUTINE fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, & + & Time, field_prev_Time, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds !output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: do_check + LOGICAL :: lims_not_exact + + err_msg = '' + + ! Check bounds only when the value of Time changes. When windows are used, + ! a change in Time indicates that a new loop through the windows has begun, + ! so a check of the previous loop can be done. + IF ( Time == field_prev_Time ) THEN + do_check = .FALSE. + ELSE + IF ( field_prev_Time == Time_zero ) THEN + ! It may or may not be OK to check, I don't know how to tell. + ! Check will be done on subsequent calls anyway. + do_check = .FALSE. + ELSE + do_check = .TRUE. + END IF + field_prev_Time = Time + END IF + + IF ( do_check ) THEN + lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, & + & error_string2, a_noteq_b, a_noteq_b) + IF( lims_not_exact .eqv. .TRUE.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) + END IF + call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) + END IF +END SUBROUTINE fms_diag_check_bounds_are_exact_dynamic + + +!> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to +!! maintain an interface servicing the legacy diag_manager. +SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if + !! output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< module name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_dynamic(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, & + & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) + +END SUBROUTINE check_bounds_are_exact_dynamic - IF ( do_check ) THEN - IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) - END IF - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - END IF - END SUBROUTINE check_bounds_are_exact_dynamic !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. + !! output_fields(out_num)%buffer upper and lower bounds. SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message + !! if the check fails. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message + TYPE (fmsDiagIbounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL current_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) + + CALL fms_diag_check_bounds_are_exact_static(current_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, err_msg) + END SUBROUTINE check_bounds_are_exact_static + + + !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those + !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds. + !! If there is an error then error message will be filled. + SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg) + TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Initialize the output file. SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,& @@ -1325,12 +1476,8 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 - output_fields(out_num)%imax = 0 - output_fields(out_num)%jmax = 0 - output_fields(out_num)%kmax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH + + call output_fields(out_num)%buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ! initialize the size of the diurnal axis to 1 output_fields(out_num)%n_diurnal_samples = 1 diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 2f3b8f066d..713e37529c 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -20,7 +20,7 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & - & diag_log_unit, CMOR_MISSING_VALUE, use_cmor + &get_base_time USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & & get_ticks_per_second @@ -31,11 +31,14 @@ module fms_diag_object_mod & get_diag_files_id, diag_yaml use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, & &diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, & - &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type -use fms_diag_buffer_mod + &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, & + &parse_compress_att, get_axis_id_from_name +use fms_diag_output_buffer_mod +#endif +#if defined(_OPENMP) +use omp_lib #endif use mpp_domains_mod, only: domain1d, domain2d, domainUG, null_domain2d -use platform_mod implicit none private @@ -46,9 +49,11 @@ 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(fmsDiagBufferContainer_type), allocatable :: FMS_diag_buffers(:) !< array of buffer objects + type(fmsDiagOutputBufferContainer_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 + type(time_type) :: current_model_time !< The current model time integer, private :: registered_variables !< Number of registered variables integer, private :: registered_axis !< Number of registered axis logical, private :: initialized=.false. !< True if the fmsDiagObject is initialized @@ -71,7 +76,9 @@ module fms_diag_object_mod procedure :: fms_get_axis_length procedure :: fms_get_diag_field_id_from_name procedure :: fms_get_axis_name_from_id + procedure :: fms_diag_accept_data procedure :: fms_diag_send_complete + procedure :: fms_diag_do_io #ifdef use_yaml procedure :: get_diag_buffer #endif @@ -107,9 +114,10 @@ subroutine fms_diag_object_init (this,diag_subset_output) this%axes_initialized = fms_diag_axis_object_init(this%diag_axis) this%files_initialized = fms_diag_files_object_init(this%FMS_diag_files) this%fields_initialized = fms_diag_fields_object_init(this%FMS_diag_fields) - this%buffers_initialized = fms_diag_buffer_init(this%FMS_diag_buffers, SIZE(diag_yaml%get_diag_fields())) + this%buffers_initialized =fms_diag_output_buffer_init(this%FMS_diag_output_buffers,SIZE(diag_yaml%get_diag_fields())) this%registered_variables = 0 this%registered_axis = 0 + this%current_model_time = get_base_time() this%initialized = .true. #else call mpp_error("fms_diag_object_init",& @@ -121,26 +129,23 @@ end subroutine fms_diag_object_init !! Closes all files !! Deallocates all buffers, fields, and files !! Uninitializes the fms_diag_object -subroutine fms_diag_object_end (this) +subroutine fms_diag_object_end (this, time) class(fmsDiagObject_type) :: this + TYPE(time_type), INTENT(in) :: time + integer :: i #ifdef use_yaml !TODO: loop through files and force write if (.not. this%initialized) return - do i = 1, size(this%FMS_diag_files) - !< Go away if the file is a subregional file and the current PE does not have any data for it - if (.not. this%FMS_diag_files(i)%writing_on_this_pe()) cycle - - call this%FMS_diag_files(i)%close_diag_file() - enddo + 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_buffers) - if(allocated(this%FMS_diag_buffers(i)%diag_buffer_obj)) then - call this%FMS_diag_buffers(i)%diag_buffer_obj%flush_buffer() + 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 enddo - deallocate(this%FMS_diag_buffers) + deallocate(this%FMS_diag_output_buffers) this%axes_initialized = fms_diag_axis_object_end(this%diag_axis) this%initialized = .false. call diag_yaml_object_end @@ -155,7 +160,7 @@ end subroutine fms_diag_object_end integer function fms_register_diag_field_obj & (this, modname, varname, axes, init_time, & longname, units, missing_value, varRange, mask_variant, standname, & - err_msg, interp_method, tile_count, area, volume, realm, static) + do_not_log, err_msg, interp_method, tile_count, area, volume, realm, static) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: modname !< The module name @@ -168,6 +173,7 @@ integer function fms_register_diag_field_obj & class(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a attribute class(*), OPTIONAL, INTENT(in) :: varRANGE(2) !< Range to add as a attribute LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field info is not logged CHARACTER(len=*), OPTIONAL, INTENT(out) :: err_msg !< Error message to be passed back up CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. @@ -208,41 +214,45 @@ integer function fms_register_diag_field_obj & !> Use pointers for convenience fieldptr => this%FMS_diag_fields(this%registered_variables) !> Register the data for the field - call fieldptr%register(modname, varname, diag_field_indices, fms_diag_object%diag_axis, & - axes, longname, units, missing_value, varRange, mask_variant, standname, & - err_msg=err_msg, interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, & + call fieldptr%register(modname, varname, diag_field_indices, this%diag_axis, & + axes=axes, longname=longname, units=units, missing_value=missing_value, varRange= varRange, & + mask_variant= mask_variant, standname=standname, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm, & static=static) !> Get the file IDs from the field indicies from the yaml file_ids = get_diag_files_id(diag_field_indices) + call fieldptr%set_file_ids(file_ids) !> Add the axis information, initial time, and field IDs to the files if (present(axes) .and. present(init_time)) then do i = 1, size(file_ids) fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file - call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) - call fileptr%add_axes(axes, this%diag_axis, this%registered_axis) - call fileptr%add_start_time(init_time) + call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i)) + call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i)) + call fileptr%add_start_time(init_time, this%current_model_time) call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) enddo elseif (present(axes)) then !only axes present do i = 1, size(file_ids) fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file - call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%init_diurnal_axis(this%diag_axis, this%registered_axis, diag_field_indices(i)) call fileptr%set_file_domain(fieldptr%get_domain(), fieldptr%get_type_of_domain()) - call fileptr%add_axes(axes, this%diag_axis, this%registered_axis) + call fileptr%add_axes(axes, this%diag_axis, this%registered_axis, diag_field_indices(i)) call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) enddo elseif (present(init_time)) then !only inti time present do i = 1, size(file_ids) fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file - call fileptr%add_field_id(fieldptr%get_id()) - call fileptr%add_start_time(init_time) + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) + call fileptr%add_start_time(init_time, this%current_model_time) call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) enddo else !no axis or init time present do i = 1, size(file_ids) fileptr => this%FMS_diag_files(file_ids(i))%FMS_diag_file - call fileptr%add_field_id(fieldptr%get_id()) + call fileptr%add_field_and_yaml_id(fieldptr%get_id(), diag_field_indices(i)) call fileptr%set_file_time_ops (fieldptr%diag_field(i), fieldptr%is_static()) enddo endif @@ -255,7 +265,7 @@ end function fms_register_diag_field_obj !> @brief Registers a scalar field !! @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, init_time, & - & long_name, units, missing_value, var_range, standard_name, err_msg,& + & long_name, units, missing_value, var_range, standard_name, do_not_log, err_msg,& & area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from @@ -266,6 +276,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file CLASS(*), OPTIONAL, INTENT(in) :: missing_value !< Missing value to add as a variable attribute CLASS(*), OPTIONAL, INTENT(in) :: var_range(:) !< Range to add a variable attribute + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call INTEGER, OPTIONAL, INTENT(in) :: area !< Id of the area field INTEGER, OPTIONAL, INTENT(in) :: volume !< Id of the volume field @@ -277,7 +288,7 @@ INTEGER FUNCTION fms_register_diag_field_scalar(this,module_name, field_name, in fms_register_diag_field_scalar = this%register(& & module_name, field_name, init_time=init_time, & & longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & standname=standard_name, err_msg=err_msg, & + & standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & area=area, volume=volume, realm=realm) #endif end function fms_register_diag_field_scalar @@ -286,7 +297,7 @@ end function fms_register_diag_field_scalar !> @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, axes, init_time, & & long_name, units, missing_value, var_range, mask_variant, standard_name, verbose,& - & err_msg, interp_method, tile_count, area, volume, realm) + & do_not_log, err_msg, interp_method, tile_count, area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Module where the field comes from CHARACTER(len=*), INTENT(in) :: field_name !< Name of the field @@ -299,6 +310,7 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Mask variant CHARACTER(len=*), OPTIONAL, INTENT(in) :: standard_name !< Standard_name to name the variable in the file LOGICAL, OPTIONAL, INTENT(in) :: verbose !< Print more information + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< If TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(out):: err_msg !< Error_msg from call CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing. @@ -316,7 +328,7 @@ INTEGER FUNCTION fms_register_diag_field_array(this, module_name, field_name, ax fms_register_diag_field_array = this%register( & & module_name, field_name, init_time=init_time, & & axes=axes, longname=long_name, units=units, missing_value=missing_value, varrange=var_range, & - & mask_variant=mask_variant, standname=standard_name, err_msg=err_msg, & + & mask_variant=mask_variant, standname=standard_name, do_not_log=do_not_log, err_msg=err_msg, & & interp_method=interp_method, tile_count=tile_count, area=area, volume=volume, realm=realm) #endif end function fms_register_diag_field_array @@ -324,7 +336,7 @@ end function fms_register_diag_field_array !> @brief Return field index for subsequent call to send_data. !! @return field index for subsequent call to send_data. INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, DYNAMIC, interp_method,& + & missing_value, range, mask_variant, standard_name, DYNAMIC, do_not_log, interp_method,& & tile_count, area, volume, realm) class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill CHARACTER(len=*), INTENT(in) :: module_name !< Name of the module, the field is on @@ -338,6 +350,7 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, LOGICAL, OPTIONAL, INTENT(in) :: mask_variant !< Flag indicating if the field is has !! a mask variant LOGICAL, OPTIONAL, INTENT(in) :: DYNAMIC !< Flag indicating if the field is dynamic + LOGICAL, OPTIONAL, INTENT(in) :: do_not_log !< if TRUE, field information is not logged CHARACTER(len=*), OPTIONAL, INTENT(in) :: interp_method !< The interp method to be used when !! regridding the field in post-processing !! Valid options are "conserve_order1", @@ -358,6 +371,7 @@ INTEGER FUNCTION fms_register_static_field(this, module_name, field_name, axes, fms_register_static_field = this%register( & & module_name, field_name, axes=axes, & & longname=long_name, units=units, missing_value=missing_value, varrange=range, & + & mask_variant=mask_variant, do_not_log=do_not_log, interp_method=interp_method, tile_count=tile_count, & & standname=standard_name, area=area, volume=volume, realm=realm, & & static=.true.) #endif @@ -366,7 +380,7 @@ end function fms_register_static_field !> @brief Wrapper for the register_diag_axis subroutine. This is needed to keep the diag_axis_init !! interface the same !> @return Axis id -FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_name, direction,& +FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, axis_length, long_name, direction,& & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count, domain_position ) & & result(id) @@ -375,6 +389,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n CLASS(*), INTENT(in) :: axis_data(:) !< Array of coordinate values CHARACTER(len=*), INTENT(in) :: units !< Units for the axis CHARACTER(len=1), INTENT(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", "U", "N") + integer, intent(in) :: axis_length !< The length of the axis size(axis_data(:)) CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name !< Long name for the axis. CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name !< Name of the parent axis, if it is a subaxis INTEGER, INTENT(in), OPTIONAL :: direction !< Indicates the direction of the axis @@ -416,7 +431,7 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n endif call axis%register(axis_name, axis_data, units, cart_name, long_name=long_name, & & direction=direction, set_name=set_name, Domain=Domain, Domain2=Domain2, DomainU=DomainU, aux=aux, & - & req=req, tile_count=tile_count, domain_position=domain_position) + & req=req, tile_count=tile_count, domain_position=domain_position, axis_length=axis_length) id = this%registered_axis call axis%set_axis_id(id) @@ -424,21 +439,154 @@ FUNCTION fms_diag_axis_init(this, axis_name, axis_data, units, cart_name, long_n #endif end function fms_diag_axis_init +!> Accepts data from the send_data functions. If this is in an openmp region with more than +!! one thread, the data is buffered in the field object and processed later. If only a single thread +!! is being used, then the processing can be done and stored in the buffer object. The hope is that +!! the increase in memory footprint related to buffering can be handled by the shared memory of the +!! multithreaded case. +!! \note If some of the diag manager is offloaded in the future, then it should be treated similarly +!! to the multi-threaded option for processing later +logical function fms_diag_accept_data (this, diag_field_id, field_data, time, is_in, js_in, ks_in, & + mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + class(fmsDiagObject_type),TARGET,INTENT(inout):: this !< Diaj_obj to fill + INTEGER, INTENT(in) :: diag_field_id !< The ID of the input diagnostic field + CLASS(*), DIMENSION(:,:,:,:), INTENT(in) :: field_data !< The data for the input diagnostic + CLASS(*), INTENT(in), OPTIONAL :: weight !< The weight used for averaging + TYPE (time_type), INTENT(in), OPTIONAL :: time !< The current time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in !< Indicies for the variable + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< The location of the mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask !< The masking values + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg !< An error message returned + integer :: is, js, ks !< Starting indicies of the field_data + integer :: ie, je, ke !< Ending indicied of the field_data + integer :: n1, n2, n3 !< Size of the 3 indicies of the field data + integer :: omp_num_threads !< Number of openmp threads + integer :: omp_level !< The openmp active level + logical :: buffer_the_data !< True if the user selects to buffer the data and run the calculations + !! later. \note This is experimental +#ifndef use_yaml +CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") +#else +!> Does the user want to push off calculations until send_diag_complete? + buffer_the_data = .false. +!> initialize the number of threads and level to be 0 + omp_num_threads = 0 + omp_level = 0 +#if defined(_OPENMP) + omp_num_threads = omp_get_num_threads() + omp_level = omp_get_level() + buffer_the_data = (omp_num_threads > 1 .AND. omp_level > 0) +#endif +!If this is true, buffer data + main_if: if (buffer_the_data) then +!> Calculate the i,j,k start and end + ! If is, js, or ks not present default them to 1 + is = 1 + js = 1 + ks = 1 + IF ( PRESENT(is_in) ) is = is_in + IF ( PRESENT(js_in) ) js = js_in + IF ( PRESENT(ks_in) ) ks = ks_in + n1 = SIZE(field_data, 1) + n2 = SIZE(field_data, 2) + n3 = SIZE(field_data, 3) + ie = is+n1-1 + je = js+n2-1 + ke = ks+n3-1 + IF ( PRESENT(ie_in) ) ie = ie_in + IF ( PRESENT(je_in) ) je = je_in + IF ( PRESENT(ke_in) ) ke = ke_in +!> Buffer the data + call this%FMS_diag_fields(diag_field_id)%set_data_buffer(field_data, FMS_diag_object%diag_axis,& + is, js, ks, ie, je, ke) + call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.TRUE.) + fms_diag_accept_data = .TRUE. + return + else +!!TODO: Loop through fields and do averages/math functions + call this%FMS_diag_fields(diag_field_id)%set_math_needs_to_be_done(.FALSE.) + fms_diag_accept_data = .TRUE. + return + end if main_if +!> Return false if nothing is done + fms_diag_accept_data = .FALSE. + return +#endif +end function fms_diag_accept_data +!! TODO: This entire routine !> @brief Loops through all the files, open the file, writes out axis and !! variable metadata and data when necessary. subroutine fms_diag_send_complete(this, time_step) - class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object - TYPE (time_type), INTENT(in) :: time_step !< The current model time + class(fmsDiagObject_type), target, intent (inout) :: this !< The diag object + TYPE (time_type), INTENT(in) :: time_step !< The time_step integer :: i !< For do loops + integer :: ifile !< For file loops + integer :: ifield !< For field loops #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else + + class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience + class(fmsDiagField_type), pointer :: diag_field !< Pointer to this%FMS_diag_files(i)%diag_field(j) + logical :: math !< True if the math functions need to be called using the data buffer, + !! False if the math functions were done in accept_data + integer, dimension(:), allocatable :: file_field_ids !< Array of field IDs for a file + + !< Update the current model time by adding the time_step + this%current_model_time = this%current_model_time + time_step + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! In the future, this may be parallelized for offloading + file_loop: do ifile = 1, size(this%FMS_diag_files) + diag_file => this%FMS_diag_files(ifile) + field_outer_if: if (size(diag_file%FMS_diag_file%get_field_ids()) .ge. 1) then + allocate (file_field_ids(size(diag_file%FMS_diag_file%get_field_ids() ))) + file_field_ids = diag_file%FMS_diag_file%get_field_ids() + field_loop: do ifield = 1, size(file_field_ids) + ! If the field is not registered go away + if (.not. diag_file%FMS_diag_file%is_field_registered(ifield)) cycle + + diag_field => this%FMS_diag_fields(file_field_ids(ifield)) + !> Check if math needs to be done + ! math = diag_field%get_math_needs_to_be_done() + math = .false. !TODO: replace this with real thing + calling_math: if (math) then + !!TODO: call math functions !! + endif calling_math + !> Clean up, clean up, everybody everywhere + if (associated(diag_field)) nullify(diag_field) + enddo field_loop + !> Clean up, clean up, everybody do your share + if (allocated(file_field_ids)) deallocate(file_field_ids) + endif field_outer_if + enddo file_loop + + call this%fms_diag_do_io() +#endif + +end subroutine fms_diag_send_complete + +!> @brief Loops through all the files, open the file, writes out axis and +!! variable metadata and data when necessary. +subroutine fms_diag_do_io(this, is_end_of_run) + class(fmsDiagObject_type), target, intent(inout) :: this !< The diag object + logical, optional, intent(in) :: is_end_of_run !< If .true. this is the end of the run, + !! so force write +#ifdef use_yaml + integer :: i !< For do loops class(fmsDiagFileContainer_type), pointer :: diag_file !< Pointer to this%FMS_diag_files(i) (for convenience) + TYPE (time_type), pointer :: model_time!< The current model time logical :: file_is_opened_this_time_step !< True if the file was opened in this time_step !! If true the metadata will need to be written + logical :: force_write + + force_write = .false. + if (present (is_end_of_run)) force_write = .true. + + model_time => this%current_model_time do i = 1, size(this%FMS_diag_files) diag_file => this%FMS_diag_files(i) @@ -446,25 +594,29 @@ subroutine fms_diag_send_complete(this, time_step) !< Go away if the file is a subregional file and the current PE does not have any data for it if (.not. diag_file%writing_on_this_pe()) cycle - call diag_file%open_diag_file(time_step, file_is_opened_this_time_step) + call diag_file%open_diag_file(model_time, file_is_opened_this_time_step) if (file_is_opened_this_time_step) then call diag_file%write_time_metadata() call diag_file%write_axis_metadata(this%diag_axis) + call diag_file%write_field_metadata(this%FMS_diag_fields, this%diag_axis) call diag_file%write_axis_data(this%diag_axis) endif - if (diag_file%is_time_to_write(time_step)) then + if (diag_file%is_time_to_write(model_time)) then call diag_file%increase_unlimited_dimension() call diag_file%write_time_data() !TODO call diag_file%add_variable_data() - call diag_file%update_next_write(time_step) - call diag_file%update_current_new_file_freq_index(time_step) - if (diag_file%is_time_to_close_file(time_step)) call diag_file%close_diag_file + call diag_file%update_next_write(model_time) + call diag_file%update_current_new_file_freq_index(model_time) + if (diag_file%is_time_to_close_file(model_time)) call diag_file%close_diag_file() + else if (force_write .and. .not. diag_file%is_file_static()) then + call diag_file%increase_unlimited_dimension() + call diag_file%write_time_data() + call diag_file%close_diag_file() endif enddo #endif - -end subroutine fms_diag_send_complete +end subroutine fms_diag_do_io !> @brief Add a attribute to the diag_obj using the diag_field_id subroutine fms_diag_field_add_attribute(this, diag_field_id, att_name, att_value) @@ -492,6 +644,9 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value) character(len=*), intent(in) :: att_name !< Name of the attribute class(*), intent(in) :: att_value(:) !< The attribute value to add + character(len=20) :: axis_names(2) !< Names of the uncompress axis + integer :: uncmx_ids(2) !< Ids of the uncompress axis + integer :: j !< For do loops #ifndef use_yaml CALL MPP_ERROR(FATAL,"You can not use the modern diag manager without compiling with -Duse_yaml") #else @@ -501,6 +656,25 @@ subroutine fms_diag_axis_add_attribute(this, axis_id, att_name, att_value) select type (axis => this%diag_axis(axis_id)%axis) type is (fmsDiagFullAxis_type) call axis%add_axis_attribute(att_name, att_value) + + !! Axis that are in the "unstructured" domain require a "compress" attribute for the + !! combiner and PP. This attribute is passed in via a diag_axis_add_attribute call in the model code + !! The compress attribute indicates the names of the axis that were compressed + !! For example grid_index:compress = "grid_yt grid_xt" + !! The metadata and the data for these axis also needs to be written to the file + if (trim(att_name) .eq. "compress") then + !< If the attribute is the "compress" attribute, get the axis names, + !! and the ids of the axis and add it to the axis object so it can be written to netcdf files + !! that use this axis + axis_names = parse_compress_att(att_value) + do j = 1, size(axis_names) + uncmx_ids(j) = get_axis_id_from_name(axis_names(j), this%diag_axis, this%registered_axis) + if (uncmx_ids(j) .eq. diag_null) call mpp_error(FATAL, & + &"Error parsing the compress attribute for axis: "//trim(axis%get_axis_name())//& + &". Be sure that the axes in the compress attribute are registered") + enddo + call axis%add_structured_axis_ids(uncmx_ids) + endif end select #endif end subroutine fms_diag_axis_add_attribute @@ -508,9 +682,9 @@ end subroutine fms_diag_axis_add_attribute #ifdef use_yaml !> \brief Gets the diag field ID from the module name and field name. !> \returns a copy of the ID of the diag field or DIAG_FIELD_NOT_FOUND if the field is not registered -PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, field_name) & +PURE FUNCTION fms_get_diag_field_id_from_name(this, module_name, field_name) & result(diag_field_id) - class(fmsDiagObject_type), intent (in) :: fms_diag_object !< The diag object + class(fmsDiagObject_type), intent (in) :: this !< The diag object, the caller CHARACTER(len=*), INTENT(in) :: module_name !< Module name that registered the variable CHARACTER(len=*), INTENT(in) :: field_name !< Variable name integer :: diag_field_id @@ -518,9 +692,9 @@ PURE FUNCTION fms_get_diag_field_id_from_name(fms_diag_object, module_name, fiel !> Initialize to not found diag_field_id = DIAG_FIELD_NOT_FOUND !> Loop through fields to find it. - if (fms_diag_object%registered_variables < 1) return - do i=1,fms_diag_object%registered_variables - diag_field_id = fms_diag_object%FMS_diag_fields(i)%id_from_name(module_name, field_name) + if (this%registered_variables < 1) return + do i=1, this%registered_variables + diag_field_id = this%FMS_diag_fields(i)%id_from_name(module_name, field_name) if(diag_field_id .ne. DIAG_FIELD_NOT_FOUND) return enddo END FUNCTION fms_get_diag_field_id_from_name @@ -548,10 +722,11 @@ function get_diag_buffer(this, bufferid) & result(rslt) class(fmsDiagObject_type), intent(in) :: this integer, intent(in) :: bufferid - class(fmsDiagBuffer_class),allocatable:: rslt - if( (bufferid .gt. UBOUND(this%FMS_diag_buffers, 1)) .or. (bufferid .lt. UBOUND(this%FMS_diag_buffers, 1))) & + class(fmsDiagOutputBuffer_class),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 = fms_diag_object%FMS_diag_buffers(bufferid)%diag_buffer_obj + rslt = this%FMS_diag_output_buffers(bufferid)%diag_buffer_obj end function #endif @@ -674,6 +849,4 @@ subroutine dump_diag_obj( filename ) call mpp_error( FATAL, "You can not use the modern diag manager without compiling with -Duse_yaml") #endif end subroutine - - end module fms_diag_object_mod From 2382a5f6894ab7a35c39c02b7d3d05c388e1ec93 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 7 Apr 2023 14:03:54 -0400 Subject: [PATCH 09/13] fix issues with merge; add to static register routine --- diag_manager/diag_manager.F90 | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index ad8795aca4..e9347fe1d6 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -411,7 +411,7 @@ INTEGER FUNCTION register_diag_field_scalar(module_name, field_name, init_time, if(.not. do_not_log) call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name,& & units, missing_value, range, dynamic=.true.) else - call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), "", long_name, units,& + call log_diag_field_info(module_name, field_name, (/NULL_AXIS_ID/), long_name, units,& & missing_value, range, dynamic=.true.) endif endif @@ -456,10 +456,10 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t if (use_modern_diag) then if( do_diag_field_log) then if ( PRESENT(do_not_log) ) THEN - if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, "", long_name,& + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,& & units, missing_value, range, dynamic=.true.) else - call log_diag_field_info(module_name, field_name, axes, "", long_name, units,& + call log_diag_field_info(module_name, field_name, axes, long_name, units,& & missing_value, range, dynamic=.true.) endif endif @@ -512,6 +512,15 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, END IF if (use_modern_diag) then + if( do_diag_field_log) then + if ( PRESENT(do_not_log) ) THEN + if(.not. do_not_log) call log_diag_field_info(module_name, field_name, axes, long_name,& + & units, missing_value, range, dynamic=.false.) + else + call log_diag_field_info(module_name, field_name, axes, long_name, units,& + & missing_value, range, dynamic=.false.) + endif + endif register_static_field = fms_diag_object%fms_register_static_field(module_name, field_name, axes, & & long_name=long_name, units=units, missing_value=missing_value, range=range, mask_variant=mask_variant, & & standard_name=standard_name, dynamic=DYNAMIC, do_not_log=do_not_log, interp_method=interp_method,& From 79d548fb66cf559f29ad62c64bf54623f4dcf1cd Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 7 Apr 2023 14:07:27 -0400 Subject: [PATCH 10/13] missed some prints --- diag_manager/fms_diag_yaml.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/diag_manager/fms_diag_yaml.F90 b/diag_manager/fms_diag_yaml.F90 index 2b4725c632..f934fb640c 100644 --- a/diag_manager/fms_diag_yaml.F90 +++ b/diag_manager/fms_diag_yaml.F90 @@ -505,7 +505,6 @@ subroutine fill_in_diag_files(diag_yaml_id, diag_file_id, fileobj) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "file_name", fileobj%file_fname) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq_units", buffer) call diag_get_value_from_key(diag_yaml_id, diag_file_id, "freq", freq_buffer) - print *, "read freq:", freq_buffer call set_file_freq(fileobj, freq_buffer, buffer) deallocate(freq_buffer, buffer) @@ -708,8 +707,6 @@ subroutine set_file_freq(fileobj, file_freq, file_frequnit) read(file_freq, *, iostat=err_unit) fileobj%file_freq read(file_frequnit, *, iostat=err_unit) file_freq_units - print *, "set file freq:", fileobj%file_fname - do i = 1, MAX_FREQ if (fileobj%file_freq(i) >= -1) then if (trim(file_freq_units(i)) .eq. "") & From 6f0b5ad0aa5305392820ce9049776f0f1fa1326d Mon Sep 17 00:00:00 2001 From: rem1776 Date: Tue, 18 Apr 2023 12:25:03 -0400 Subject: [PATCH 11/13] fix errors with scalars --- diag_manager/fms_diag_object.F90 | 14 +++++++++++--- test_fms/diag_manager/test_diag_manager2.sh | 2 +- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 713e37529c..5d3c7f838f 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -20,7 +20,7 @@ module fms_diag_object_mod use mpp_mod, only: fatal, note, warning, mpp_error, mpp_pe, mpp_root_pe, stdout use diag_data_mod, only: diag_null, diag_not_found, diag_not_registered, diag_registered_id, & &DIAG_FIELD_NOT_FOUND, diag_not_registered, max_axes, TWO_D_DOMAIN, & - &get_base_time + &get_base_time, NULL_AXIS_ID USE time_manager_mod, ONLY: set_time, set_date, get_time, time_type, OPERATOR(>=), OPERATOR(>),& & OPERATOR(<), OPERATOR(==), OPERATOR(/=), OPERATOR(/), OPERATOR(+), ASSIGNMENT(=), get_date, & & get_ticks_per_second @@ -28,7 +28,7 @@ module fms_diag_object_mod use fms_diag_file_object_mod, only: fmsDiagFileContainer_type, fmsDiagFile_type, fms_diag_files_object_init use fms_diag_field_object_mod, only: fmsDiagField_type, fms_diag_fields_object_init use fms_diag_yaml_mod, only: diag_yaml_object_init, diag_yaml_object_end, find_diag_field, & - & get_diag_files_id, diag_yaml + & get_diag_files_id, diag_yaml use fms_diag_axis_object_mod, only: fms_diag_axis_object_init, fmsDiagAxis_type, fmsDiagSubAxis_type, & &diagDomain_t, get_domain_and_domain_type, diagDomain2d_t, & &fmsDiagAxisContainer_type, fms_diag_axis_object_end, fmsDiagFullAxis_type, & @@ -789,7 +789,15 @@ function fms_get_axis_name_from_id (this, axis_id) & axis_name=" " #else if (axis_id < 0 .and. axis_id > this%registered_axis) & - call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") + call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") + + !! if its a scalar (null axis id) just returns the old default axes name for scalars + if (axis_id .eq. NULL_AXIS_ID) then + allocate(character(len=11) :: axis_name) + axis_name = "scalar_axis" + return + endif + select type (axis => this%diag_axis(axis_id)%axis) type is (fmsDiagFullAxis_type) diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index 83e99cf020..2b47186f99 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -45,7 +45,7 @@ setup_test () { &diag_manager_nml max_field_attributes=3 debug_diag_manager=.true. - + do_diag_field_log=.true. / &ensemble_nml From 8a55506e7bec19a066014542681e3bb7d9cdf677 Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 21 Apr 2023 08:15:19 -0400 Subject: [PATCH 12/13] change scalar axis_name to better reflect code changes --- diag_manager/fms_diag_object.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 5d3c7f838f..9e72fe6736 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -791,10 +791,10 @@ function fms_get_axis_name_from_id (this, axis_id) & if (axis_id < 0 .and. axis_id > this%registered_axis) & call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") - !! if its a scalar (null axis id) just returns the old default axes name for scalars + !! if its a scalar (null axis id) just returns n/a since no axis is defined if (axis_id .eq. NULL_AXIS_ID) then - allocate(character(len=11) :: axis_name) - axis_name = "scalar_axis" + allocate(character(len=3) :: axis_name) + axis_name = "n/a" return endif From 6f5f556c9d810078e49ee8951cd4960e0be99d0d Mon Sep 17 00:00:00 2001 From: rem1776 Date: Fri, 21 Apr 2023 08:17:02 -0400 Subject: [PATCH 13/13] whitespace --- diag_manager/fms_diag_object.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/fms_diag_object.F90 b/diag_manager/fms_diag_object.F90 index 9e72fe6736..765d9f4bab 100644 --- a/diag_manager/fms_diag_object.F90 +++ b/diag_manager/fms_diag_object.F90 @@ -791,7 +791,7 @@ function fms_get_axis_name_from_id (this, axis_id) & if (axis_id < 0 .and. axis_id > this%registered_axis) & call mpp_error(FATAL, "fms_get_axis_length: The axis_id is not valid") - !! if its a scalar (null axis id) just returns n/a since no axis is defined + !! if its a scalar (null axis id) just returns n/a since no axis is defined if (axis_id .eq. NULL_AXIS_ID) then allocate(character(len=3) :: axis_name) axis_name = "n/a"