From e59ef820570d26dc3fe0f706c42ce0dd2c0f82fc Mon Sep 17 00:00:00 2001 From: Mirco Valentini Date: Tue, 17 Dec 2024 01:57:49 +0000 Subject: [PATCH] Feature initial version of the ERA6 multiom-rules structure --- CMakeLists.txt | 1 + src/multiom/common/datetime_utils_mod.F90 | 1108 +++- src/multiom/common/enumerators_mod.F90 | 12 +- src/multiom/common/log_info_mod.F90 | 2 +- .../mars/fortran_message_enumerators_mod.F90 | 8 +- .../mars/fortran_message_mod.F90 | 1218 ++-- .../data-structures/mars/record_base_mod.F90 | 125 - .../mars/records/class_record_mod.F90 | 2316 ++++++++ .../mars/records/levtype_record_mod.F90 | 2316 ++++++++ .../mars/records/origin_record_mod.F90 | 2316 ++++++++ .../mars/records/packing_record_mod.F90 | 2316 ++++++++ .../mars/records/record_base_mod.F90 | 677 +++ .../mars/records/repres_record_mod.F90 | 2316 ++++++++ .../mars/records/stream_record_mod.F90 | 2316 ++++++++ .../mars/records/type_record_mod.F90 | 2316 ++++++++ .../parametrization/CMakeLists.txt | 2 + .../parametrization/analysis_par_mod.F90 | 134 +- .../parametrization/bitmap_par_mod.F90 | 148 +- .../data_representation_par_mod.F90 | 100 +- .../parametrization/ensemble_par_mod.F90 | 199 +- .../parametrization/geometry_par_mod.F90 | 314 +- .../parametrization/level_par_mod.F90 | 286 +- .../parametrization_enumerators_mod.F90 | 30 +- .../parametrization/parametrization_mod.F90 | 356 +- .../parametrization/repres_map_mod.F90 | 5026 +++++++++++++++++ .../parametrization/representations_mod.F90 | 437 ++ .../parametrization/satellite_par_mod.F90 | 92 + .../parametrization/time_par_mod.F90 | 189 +- .../parametrization/wave_par_mod.F90 | 322 ++ .../cached_encoder_collection_mod.F90 | 135 + .../encoding-rules/cached_encoder_mod.F90 | 146 + .../multiom_cached_encoder_mod.F90 | 46 +- src/multiom/ifs-interface/ifs_msg_mod.F90 | 3 + src/multiom/ifs-interface/ifs_par_mod.F90 | 2 +- src/multiom/ifs2mars/ifs2mars_mod.F90 | 1070 +++- src/multiom/operations/intop/CMakeLists.txt | 1 + .../operations/intop/intop_enum_mod.F90 | 685 +++ .../operations/intop/intop_factory_mod.F90 | 11 + .../output-manager/grib_header2multio_mod.F90 | 750 ++- tests/CMakeLists.txt | 1 + tests/multiom/CMakeLists.txt | 2 + tests/multiom/knowledge/49r2v9/CMakeLists.txt | 4 + .../knowledge/49r2v9/encodings/CMakeLists.txt | 15 + .../49r2v9/encodings/encoding-rules.yaml | 742 +++ .../knowledge/49r2v9/mappings/CMakeLists.txt | 15 + .../49r2v9/mappings/mapping-rules.yaml | 188 + .../knowledge/49r2v9/plans/CMakeLists.txt | 15 + .../knowledge/49r2v9/plans/multio-plans.yaml | 10 + .../knowledge/49r2v9/samples/CMakeLists.txt | 15 + .../knowledge/49r2v9/samples/sample.tmpl | Bin 0 -> 1124 bytes tests/multiom/knowledge/CMakeLists.txt | 13 + 51 files changed, 29507 insertions(+), 1360 deletions(-) delete mode 100644 src/multiom/data-structures/mars/record_base_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/class_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/levtype_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/origin_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/packing_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/record_base_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/repres_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/stream_record_mod.F90 create mode 100644 src/multiom/data-structures/mars/records/type_record_mod.F90 create mode 100644 src/multiom/data-structures/parametrization/repres_map_mod.F90 create mode 100644 src/multiom/data-structures/parametrization/representations_mod.F90 create mode 100644 src/multiom/operations/intop/intop_enum_mod.F90 create mode 100644 tests/multiom/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/encodings/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/encodings/encoding-rules.yaml create mode 100644 tests/multiom/knowledge/49r2v9/mappings/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/mappings/mapping-rules.yaml create mode 100644 tests/multiom/knowledge/49r2v9/plans/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/plans/multio-plans.yaml create mode 100644 tests/multiom/knowledge/49r2v9/samples/CMakeLists.txt create mode 100644 tests/multiom/knowledge/49r2v9/samples/sample.tmpl create mode 100644 tests/multiom/knowledge/CMakeLists.txt diff --git a/CMakeLists.txt b/CMakeLists.txt index d40f2227e..f2b9e3497 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -114,6 +114,7 @@ ecbuild_add_option( FEATURE OUTPUT_MANAGER_TOOL ### export package info set( MULTIO_CONFIG_DIR share/multio/config ) +set( MULTIOM_CONFIG_DIR share/multiom/config ) set( MULTIO_INCLUDE_DIRS ${CMAKE_CURRENT_SOURCE_DIR}/src ${CMAKE_CURRENT_BINARY_DIR}/src ) set( MULTIO_LIBRARIES multio ) diff --git a/src/multiom/common/datetime_utils_mod.F90 b/src/multiom/common/datetime_utils_mod.F90 index 83cdb66ce..001ddf22e 100644 --- a/src/multiom/common/datetime_utils_mod.F90 +++ b/src/multiom/common/datetime_utils_mod.F90 @@ -50,9 +50,17 @@ MODULE DATETIME_UTILS_MOD PUBLIC :: YYYYMMDD_HHMMSS_TO_DATETIME PUBLIC :: UNPACK_YYYYMMDD PUBLIC :: PACK_YYYYMMDD +PUBLIC :: SEC2DD_SS PUBLIC :: SEC2HH_MM_SS +PUBLIC :: HH_MM_SS2SEC PUBLIC :: PACK_HHMM +PUBLIC :: PACK_HHMMSS +PUBLIC :: UNPACK_HHMM +PUBLIC :: UNPACK_HHMMSS PUBLIC :: DATE_SUB_DAYS +PUBLIC :: DATE_SUM_DAYS +PUBLIC :: HHMMSS2STRING +PUBLIC :: YYYYMMDD2STRING ! PUBLIC :: DATETIME_TO_YYYYMMDD_HHMMSS ! PUBLIC :: HH_MM_SS_TO_SECONDS @@ -71,6 +79,105 @@ MODULE DATETIME_UTILS_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SEC2DD_SS' +PP_THREAD_SAFE FUNCTION SEC2DD_SS( NSSSSS, IDD, ISS, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: NSSSSS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: IDD + INTEGER(KIND=JPIB_K), INTENT(OUT) :: ISS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !< Error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECONDS_LOWER_THAN_ZERO = 1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( NSSSSS.LT.0, ERRFLAG_SECONDS_LOWER_THAN_ZERO ) + + IDD = NSSSSS / SECONDS_IN_DAY + ISS = MOD(NSSSSS, SECONDS_IN_DAY) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_SECONDS_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Seconds lower than zero' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION SEC2DD_SS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'SEC2HH_MM_SS' PP_THREAD_SAFE FUNCTION SEC2HH_MM_SS( NSSSSS, IHH, IMM, ISS, HOOKS ) RESULT(RET) @@ -188,6 +295,122 @@ END FUNCTION SEC2HH_MM_SS #undef PP_PROCEDURE_TYPE +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'HH_MM_SS2SEC' +PP_THREAD_SAFE FUNCTION HH_MM_SS2SEC( IHH, IMM, ISS, NSSSSS, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: IHH + INTEGER(KIND=JPIB_K), INTENT(IN) :: IMM + INTEGER(KIND=JPIB_K), INTENT(IN) :: ISS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: NSSSSS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !< Error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECONDS_LOWER_THAN_ZERO = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_OUT_OF_RANGE = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_OUT_OF_RANGE = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECOND_OUT_OF_RANGE = 4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( IHH.GT.23, ERRFLAG_HOUR_OUT_OF_RANGE ) + PP_DEBUG_DEVELOP_COND_THROW( IHH.LT.0, ERRFLAG_HOUR_OUT_OF_RANGE ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.GT.59, ERRFLAG_MINUTE_OUT_OF_RANGE ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.LT.0, ERRFLAG_MINUTE_OUT_OF_RANGE ) + PP_DEBUG_DEVELOP_COND_THROW( ISS.GT.59, ERRFLAG_SECOND_OUT_OF_RANGE ) + PP_DEBUG_DEVELOP_COND_THROW( ISS.LT.0, ERRFLAG_SECOND_OUT_OF_RANGE ) + + ! Convert Hours, Minutes and Seconds to seconds + NSSSSS = IHH*3600 + IMM*60 + ISS + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( NSSSSS.LT.0, ERRFLAG_SECONDS_LOWER_THAN_ZERO ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_HOUR_OUT_OF_RANGE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range' ) + CASE (ERRFLAG_MINUTE_OUT_OF_RANGE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range' ) + CASE (ERRFLAG_SECOND_OUT_OF_RANGE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Second out of range' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION HH_MM_SS2SEC +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'UNPACK_YYYYMMDD' PP_THREAD_SAFE FUNCTION UNPACK_YYYYMMDD( IYYYYMMDD, IYYYY, IMM, IDD, HOOKS ) RESULT(RET) @@ -385,8 +608,622 @@ FUNCTION PACK_YYYYMMDD( IYYYY, IMM, IDD, IYYYYMMDD, HOOKS ) RESULT(RET) PP_TRYCALL( ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH ) DAYS_IN_MONTH( IYYYY, IMM, DIM, HOOKS ) PP_DEBUG_DEVELOP_COND_THROW( IDD.GT.DIM, ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH ) - ! Pack Year, Month and Day - IYYYYMMDD = IYYYY*10000 + IMM*100 + IDD + ! Pack Year, Month and Day + IYYYYMMDD = IYYYY*10000 + IMM*100 + IDD + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_YEAR_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Year out of range. Year lower than 0' ) + CASE (ERRFLAG_MONTH_LOWER_THAN_ONE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index lower than 1' ) + CASE (ERRFLAG_MONTH_GREATER_THAN_TWELVE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index higher than 12' ) + CASE (ERRFLAG_DAY_LOWER_THAN_ONE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index lower than 1' ) + CASE (ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index higher than the number of days in month' ) + CASE (ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to compute the number of days in the month' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACK_YYYYMMDD +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'YYYYMMDD2STRING' +FUNCTION YYYYMMDD2STRING( IYYYYMMDD, STR, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: IYYYYMMDD + CHARACTER(LEN=10), INTENT(OUT) :: STR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: DIM + INTEGER(KIND=JPIB_K) :: YYYY + INTEGER(KIND=JPIB_K) :: MN + INTEGER(KIND=JPIB_K) :: DD + + !> Error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNPACK = 0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_YEAR_LOWER_THAN_ZERO = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MONTH_LOWER_THAN_ONE = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MONTH_GREATER_THAN_TWELVE = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DAY_LOWER_THAN_ONE = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH = 5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH = 6_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_TRYCALL(ERRFLAG_UNPACK) UNPACK_YYYYMMDD( IYYYYMMDD, YYYY, MN, DD, HOOKS ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( YYYY.LT.0, ERRFLAG_YEAR_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( MN.LT.1, ERRFLAG_MONTH_LOWER_THAN_ONE ) + PP_DEBUG_DEVELOP_COND_THROW( MN.GT.12, ERRFLAG_MONTH_GREATER_THAN_TWELVE ) + PP_DEBUG_DEVELOP_COND_THROW( DD.LT.1, ERRFLAG_DAY_LOWER_THAN_ONE ) + + PP_TRYCALL( ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH ) DAYS_IN_MONTH( YYYY, MN, DIM, HOOKS ) + PP_DEBUG_DEVELOP_COND_THROW( DD.GT.DIM, ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH ) + + ! Pack Year, Month and Day + STR = REPEAT(' ',10) + WRITE(STR,'(I4.4,A1,I2.2,A1,I2.2)') YYYY, '-', MN, '-', DD + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNPACK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to unpack the date' ) + CASE (ERRFLAG_YEAR_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Year out of range. Year lower than 0' ) + CASE (ERRFLAG_MONTH_LOWER_THAN_ONE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index lower than 1' ) + CASE (ERRFLAG_MONTH_GREATER_THAN_TWELVE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index higher than 12' ) + CASE (ERRFLAG_DAY_LOWER_THAN_ONE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index lower than 1' ) + CASE (ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index higher than the number of days in month' ) + CASE (ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to compute the number of days in the month' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION YYYYMMDD2STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'HHMMSS2STRING' +FUNCTION HHMMSS2STRING( IHHMMSS, STR, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: IHHMMSS + CHARACTER(LEN=8), INTENT(OUT) :: STR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: WRITE_ERROR + INTEGER(KIND=JPIB_K) :: HH + INTEGER(KIND=JPIB_K) :: MM + INTEGER(KIND=JPIB_K) :: SS + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_LOWER_THAN_ZERO = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_23 = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNPACK = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR = 4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_DEBUG_CRITICAL_COND_THROW( IHHMMSS.LT.0, ERRFLAG_TIMEPACK_LOWER_THAN_ZERO ) + + PP_TRYCALL(ERRFLAG_UNPACK) UNPACK_HHMMSS( IHHMMSS, HH, MM, SS, HOOKS ) + + PP_DEBUG_CRITICAL_COND_THROW( HH.GT.23, ERRFLAG_HOUR_GREATER_THAN_23 ) + + + ! Pack Year, Month and Day + STR = REPEAT(' ',8) + WRITE(STR,'(I2.2,A1,I2.2,A1,I2.2)',IOSTAT=WRITE_ERROR) HH, ':', MM, ':', SS + PP_DEBUG_CRITICAL_COND_THROW( WRITE_ERROR.NE.0, ERRFLAG_WRITE_ERROR ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_TIMEPACK_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time lower than 0' ) + CASE (ERRFLAG_HOUR_GREATER_THAN_23) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index higher than 23' ) + CASE (ERRFLAG_UNPACK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to unpack the time' ) + CASE (ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error writing the time to the string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION HHMMSS2STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACK_HHMM' +FUNCTION PACK_HHMM( IHH, IMM, IHHMM, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: IHH + INTEGER(KIND=JPIB_K), INTENT(IN) :: IMM + INTEGER(KIND=JPIB_K), INTENT(OUT) :: IHHMM + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE = 4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( IHH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( IHH.GT.23, ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE ) + + ! Pack Hours and minutes + IHHMM = IHH*100 + IMM + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_HOUR_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour lower than 0' ) + CASE (ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour higher than 23' ) + CASE (ERRFLAG_MINUTE_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute lower than 0' ) + CASE (ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute higher than 59' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACK_HHMM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Unpack year, month and day. +!> +!> This function is used to unpack year, month and day into three +!> separate integers. +!> +!> @param [in] hhmmsss Packed time to be extracted +!> @param [out] hh Hours computed from the packed time +!> @param [out] mm Minutes computed from the packed time +!> @param [out] ss Seconds computed from the packed time +!> @param [inout] hooks Hooks for logging and error handling, tracing, logging etc. +!> +#define PP_PROCEDURE_TYPE 'SUBROUTINE' +#define PP_PROCEDURE_NAME 'UNPACK_HHMM' +PP_THREAD_SAFE FUNCTION UNPACK_HHMM( HHMM, HH, MM, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: HHMM + INTEGER(KIND=JPIB_K), INTENT(OUT) :: HH + INTEGER(KIND=JPIB_K), INTENT(OUT) :: MM + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_LOWER_THAN_ZERO = 1_JPIB_K +! INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_OUTOFBOUNDS = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 3_JPIB_K +! INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_23 = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_SIXTY = 6_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( HHMM.LT.0_JPIB_K, ERRFLAG_TIMEPACK_LOWER_THAN_ZERO ) + ! PP_DEBUG_DEVELOP_COND_THROW( HHMM.GT.235959_JPIB_K, ERRFLAG_TIMEPACK_OUTOFBOUNDS ) + + + ! Extract Year, Month and Day + MM = MOD(HHMM,100_JPIB_K) + HH = HHMM/100_JPIB_K + + ! Compute days in month + !! TODO: PP_TRYCALL(ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) DAYS_IN_MONTH( YYYY, MM, DIM, HOOKS ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( HH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) + ! PP_DEBUG_DEVELOP_COND_THROW( HH.GT.23, ERRFLAG_HOUR_GREATER_THAN_23 ) + PP_DEBUG_DEVELOP_COND_THROW( MM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( MM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_SIXTY ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_TIMEPACK_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time lower than 0' ) +! CASE (ERRFLAG_TIMEPACK_OUTOFBOUNDS) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time higher than 235959' ) + CASE (ERRFLAG_HOUR_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index lower than 0' ) +! CASE (ERRFLAG_HOUR_GREATER_THAN_23) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index higher than 23' ) + CASE (ERRFLAG_MINUTE_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index lower than 0' ) + CASE (ERRFLAG_MINUTE_GREATER_THAN_SIXTY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index higher than 59' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION UNPACK_HHMM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACK_HHMMSS' +FUNCTION PACK_HHMMSS( IHH, IMM, ISS, IHHMMSS, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + INTEGER(KIND=JPIB_K), INTENT(IN) :: IHH + INTEGER(KIND=JPIB_K), INTENT(IN) :: IMM + INTEGER(KIND=JPIB_K), INTENT(IN) :: ISS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: IHHMMSS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECONDS_LOWER_THAN_ZERO = 5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECONDS_GREATER_THAN_FIFTYNINE = 6_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( IHH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( IHH.GT.23, ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( IMM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE ) + PP_DEBUG_DEVELOP_COND_THROW( ISS.LT.0, ERRFLAG_SECONDS_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( ISS.GT.59, ERRFLAG_SECONDS_GREATER_THAN_FIFTYNINE ) + + ! Pack Hours and minutes + IHHMMSS = IHH*10000_JPIB_K + IMM*100_JPIB_K + ISS ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -410,18 +1247,18 @@ FUNCTION PACK_YYYYMMDD( IYYYY, IMM, IDD, IYYYYMMDD, HOOKS ) RESULT(RET) ! HAndle different errors SELECT CASE(ERRIDX) - CASE (ERRFLAG_YEAR_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Year out of range. Year lower than 0' ) - CASE (ERRFLAG_MONTH_LOWER_THAN_ONE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index lower than 1' ) - CASE (ERRFLAG_MONTH_GREATER_THAN_TWELVE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Month out of range. Month index higher than 12' ) - CASE (ERRFLAG_DAY_LOWER_THAN_ONE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index lower than 1' ) - CASE (ERRFLAG_DAY_GREATER_THAN_DAYS_IN_MONTH) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Day out of range. Day index higher than the number of days in month' ) - CASE (ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to compute the number of days in the month' ) + CASE (ERRFLAG_HOUR_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour lower than 0' ) + CASE (ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour higher than 23' ) + CASE (ERRFLAG_MINUTE_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute lower than 0' ) + CASE (ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute higher than 59' ) + CASE (ERRFLAG_SECONDS_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Seconds out of range. Index of seconds lower than 0' ) + CASE (ERRFLAG_SECONDS_GREATER_THAN_FIFTYNINE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Seconds out of range. Index of seconds higher than 59' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -440,41 +1277,61 @@ FUNCTION PACK_YYYYMMDD( IYYYY, IMM, IDD, IYYYYMMDD, HOOKS ) RESULT(RET) ! Exit point (on error) RETURN -END FUNCTION PACK_YYYYMMDD +END FUNCTION PACK_HHMMSS #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE -#define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'PACK_HHMM' -FUNCTION PACK_HHMM( IHH, IMM, IHHMM, HOOKS ) RESULT(RET) +!> +!> @brief Unpack year, month and day. +!> +!> This function is used to unpack year, month and day into three +!> separate integers. +!> +!> @param [in] hhmmsss Packed time to be extracted +!> @param [out] hh Hours computed from the packed time +!> @param [out] mm Minutes computed from the packed time +!> @param [out] ss Seconds computed from the packed time +!> @param [inout] hooks Hooks for logging and error handling, tracing, logging etc. +!> +#define PP_PROCEDURE_TYPE 'SUBROUTINE' +#define PP_PROCEDURE_NAME 'UNPACK_HHMMSS' +PP_THREAD_SAFE FUNCTION UNPACK_HHMMSS( HHMMSS, HH, MM, SS, HOOKS ) RESULT(RET) - ! Symbols imported from other modules within the project. + !> Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + ! Symbols imported by the preprocessor for tracing purposes PP_TRACE_USE_VARS IMPLICIT NONE ! Dummy arguments - INTEGER(KIND=JPIB_K), INTENT(IN) :: IHH - INTEGER(KIND=JPIB_K), INTENT(IN) :: IMM - INTEGER(KIND=JPIB_K), INTENT(OUT) :: IHHMM + INTEGER(KIND=JPIB_K), INTENT(IN) :: HHMMSS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: HH + INTEGER(KIND=JPIB_K), INTENT(OUT) :: MM + INTEGER(KIND=JPIB_K), INTENT(OUT) :: SS TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET - !> Error codes - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE = 2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE = 4_JPIB_K + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_LOWER_THAN_ZERO = 1_JPIB_K + ! INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_OUTOFBOUNDS = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 3_JPIB_K + ! INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_23 = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_SIXTY = 6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECOND_LOWER_THAN_ZERO = 7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECOND_GREATER_THAN_SIXTY = 8_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -492,20 +1349,33 @@ FUNCTION PACK_HHMM( IHH, IMM, IHHMM, HOOKS ) RESULT(RET) PP_SET_ERR_SUCCESS( RET ) ! Error handling - PP_DEBUG_DEVELOP_COND_THROW( IHH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( IHH.GT.23, ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE ) - PP_DEBUG_DEVELOP_COND_THROW( IMM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( IMM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE ) + PP_DEBUG_DEVELOP_COND_THROW( HHMMSS.LT.0_JPIB_K, ERRFLAG_TIMEPACK_LOWER_THAN_ZERO ) +! PP_DEBUG_DEVELOP_COND_THROW( HHMMSS.GT.235959_JPIB_K, ERRFLAG_TIMEPACK_OUTOFBOUNDS ) - ! Pack Hours and minutes - IHHMM = IHH*100 + IMM + + ! Extract Year, Month and Day + SS = MOD(HHMMSS,100_JPIB_K) + MM = MOD(HHMMSS/100_JPIB_K,100_JPIB_K) + HH = HHMMSS/10000_JPIB_K + + ! Compute days in month + !! TODO: PP_TRYCALL(ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) DAYS_IN_MONTH( YYYY, MM, DIM, HOOKS ) + + ! Error handling + PP_DEBUG_DEVELOP_COND_THROW( HH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) + ! PP_DEBUG_DEVELOP_COND_THROW( HH.GT.23, ERRFLAG_HOUR_GREATER_THAN_23 ) + PP_DEBUG_DEVELOP_COND_THROW( MM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( MM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_SIXTY ) + PP_DEBUG_DEVELOP_COND_THROW( SS.LT.0, ERRFLAG_SECOND_LOWER_THAN_ZERO ) + PP_DEBUG_DEVELOP_COND_THROW( SS.GT.59, ERRFLAG_SECOND_GREATER_THAN_SIXTY ) ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() - ! Exit point (On success) + ! Exit point on success RETURN + ! Error handler PP_ERROR_HANDLER @@ -522,14 +1392,22 @@ FUNCTION PACK_HHMM( IHH, IMM, IHHMM, HOOKS ) RESULT(RET) ! HAndle different errors SELECT CASE(ERRIDX) + CASE (ERRFLAG_TIMEPACK_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time lower than 0' ) +! CASE (ERRFLAG_TIMEPACK_OUTOFBOUNDS) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time higher than 235959' ) CASE (ERRFLAG_HOUR_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour lower than 0' ) - CASE (ERRFLAG_HOUR_GREATER_THAN_TWENTYTHREE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Index of hour higher than 23' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index lower than 0' ) +! CASE (ERRFLAG_HOUR_GREATER_THAN_23) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index higher than 23' ) CASE (ERRFLAG_MINUTE_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute lower than 0' ) - CASE (ERRFLAG_MINUTE_GREATER_THAN_FIFTYNINE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Index of minute higher than 59' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index lower than 0' ) + CASE (ERRFLAG_MINUTE_GREATER_THAN_SIXTY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index higher than 59' ) + CASE (ERRFLAG_SECOND_LOWER_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Second out of range. Second index lower than 0' ) + CASE (ERRFLAG_SECOND_GREATER_THAN_SIXTY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Second out of range. Second index higher than 59' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -545,10 +1423,10 @@ FUNCTION PACK_HHMM( IHH, IMM, IHHMM, HOOKS ) RESULT(RET) !$omp end critical(ERROR_HANDLER) #endif - ! Exit point (on error) + ! Exit point on error RETURN -END FUNCTION PACK_HHMM +END FUNCTION UNPACK_HHMMSS #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE @@ -1820,153 +2698,7 @@ END FUNCTION UNPACK_YYYYMMDD #endif -!> -!> @brief Unpack year, month and day. -!> -!> This function is used to unpack year, month and day into three -!> separate integers. -!> -!> @param [in] hhmmsss Packed time to be extracted -!> @param [out] hh Hours computed from the packed time -!> @param [out] mm Minutes computed from the packed time -!> @param [out] ss Seconds computed from the packed time -!> @param [inout] hooks Hooks for logging and error handling, tracing, logging etc. -!> -#define PP_PROCEDURE_TYPE 'SUBROUTINE' -#define PP_PROCEDURE_NAME 'UNPACK_HHMMSS' -PP_THREAD_SAFE FUNCTION UNPACK_HHMMSS( HHMMSS, HH, MM, SS, HOOKS ) RESULT(RET) - - !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - - ! Symbols imported by the preprocessor for debugging purposes - PP_DEBUG_USE_VARS - - ! Symbols imported by the preprocessor for logging purposes - PP_LOG_USE_VARS - - ! Symbols imported by the preprocessor for tracing purposes - PP_TRACE_USE_VARS - -IMPLICIT NONE - - ! Dummy arguments - INTEGER(KIND=JPIB_K), INTENT(IN) :: HHMMSS - INTEGER(KIND=JPIB_K), INTENT(OUT) :: HH - INTEGER(KIND=JPIB_K), INTENT(OUT) :: MM - INTEGER(KIND=JPIB_K), INTENT(OUT) :: SS - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS - - !> Function result - INTEGER(KIND=JPIB_K) :: RET - - !> Local error flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_LOWER_THAN_ZERO = 1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIMEPACK_OUTOFBOUNDS = 2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_LOWER_THAN_ZERO = 3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HOUR_GREATER_THAN_23 = 4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_LOWER_THAN_ZERO = 5_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MINUTE_GREATER_THAN_SIXTY = 6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECOND_LOWER_THAN_ZERO = 7_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SECOND_GREATER_THAN_SIXTY = 8_JPIB_K - - ! Local variables declared by the preprocessor for debugging purposes - PP_DEBUG_DECL_VARS - - ! Local variables declared by the preprocessor for logging purposes - PP_LOG_DECL_VARS - - ! Local variables declared by the preprocessor for tracing purposes - PP_TRACE_DECL_VARS - - ! Trace begin of procedure - PP_TRACE_ENTER_PROCEDURE() - - ! Initialization of good path return value - PP_SET_ERR_SUCCESS( RET ) - - ! Error handling - PP_DEBUG_DEVELOP_COND_THROW( HHMMSS.LT.0_JPIB_K, ERRFLAG_TIMEPACK_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( HHMMSS.GT.235959_JPIB_K, ERRFLAG_TIMEPACK_OUTOFBOUNDS ) - - - ! Extract Year, Month and Day - SS = MOD(HHMMSS,100_JPIB_K) - MM = MOD(HHMMSS/100_JPIB_K,100_JPIB_K) - HH = HHMMSS/10000_JPIB_K - - ! Compute days in month - !! TODO: PP_TRYCALL(ERRFLAG_UNABLE_TO_COMPUTE_DAYS_IN_MONTH) DAYS_IN_MONTH( YYYY, MM, DIM, HOOKS ) - - ! Error handling - PP_DEBUG_DEVELOP_COND_THROW( HH.LT.0, ERRFLAG_HOUR_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( HH.LT.23, ERRFLAG_HOUR_GREATER_THAN_23 ) - PP_DEBUG_DEVELOP_COND_THROW( MM.LT.0, ERRFLAG_MINUTE_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( MM.GT.59, ERRFLAG_MINUTE_GREATER_THAN_SIXTY ) - PP_DEBUG_DEVELOP_COND_THROW( SS.LT.0, ERRFLAG_SECOND_LOWER_THAN_ZERO ) - PP_DEBUG_DEVELOP_COND_THROW( SS.GT.59, ERRFLAG_SECOND_GREATER_THAN_SIXTY ) - - ! Trace end of procedure (on success) - PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() - - ! Exit point on success - RETURN - - -! Error handler -PP_ERROR_HANDLER - - ! Initialization of bad path return value - PP_SET_ERR_FAILURE( RET ) - -#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) -!$omp critical(ERROR_HANDLER) - - BLOCK - - ! Error handling variables - PP_DEBUG_PUSH_FRAME() - - ! HAndle different errors - SELECT CASE(ERRIDX) - CASE (ERRFLAG_TIMEPACK_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time lower than 0' ) - CASE (ERRFLAG_TIMEPACK_OUTOFBOUNDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Packed time invalid. Packed time higher than 235959' ) - CASE (ERRFLAG_HOUR_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index lower than 0' ) - CASE (ERRFLAG_HOUR_GREATER_THAN_23) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Hour out of range. Hour index higher than 23' ) - CASE (ERRFLAG_MINUTE_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index lower than 0' ) - CASE (ERRFLAG_MINUTE_GREATER_THAN_SIXTY) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Minute out of range. Minute index higher than 59' ) - CASE (ERRFLAG_SECOND_LOWER_THAN_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Second out of range. Second index lower than 0' ) - CASE (ERRFLAG_SECOND_GREATER_THAN_SIXTY) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Second out of range. Second index higher than 59' ) - CASE DEFAULT - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) - END SELECT - - ! Trace end of procedure (on error) - PP_TRACE_EXIT_PROCEDURE_ON_ERROR() - - ! Write the error message and stop the program - PP_DEBUG_ABORT - - END BLOCK - -!$omp end critical(ERROR_HANDLER) -#endif - - ! Exit point on error - RETURN -END FUNCTION UNPACK_HHMMSS -#undef PP_PROCEDURE_NAME -#undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' diff --git a/src/multiom/common/enumerators_mod.F90 b/src/multiom/common/enumerators_mod.F90 index bcd7f6906..f864ea97b 100644 --- a/src/multiom/common/enumerators_mod.F90 +++ b/src/multiom/common/enumerators_mod.F90 @@ -2976,11 +2976,11 @@ PP_THREAD_SAFE FUNCTION IPACKING2CPACKING( IPACKING, CPACKING, HOOKS ) RESULT(RE SELECT CASE ( IPACKING ) CASE ( PACKING_GRIB_SIMPLE_E ) - CPACKING = 'grib-simple' + CPACKING = 'simple' CASE ( PACKING_GRIB_CCSDS_E ) - CPACKING = 'grib-ccsds' + CPACKING = 'ccsds' CASE ( PACKING_GRIB_COMPLEX_E ) - CPACKING = 'grib-complex' + CPACKING = 'complex' CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_PACKING ) END SELECT @@ -3095,11 +3095,11 @@ PP_THREAD_SAFE FUNCTION CPACKING2IPACKING( CPACKING, IPACKING, HOOKS ) RESULT(RE !> Select the repres SELECT CASE ( TRIM(ADJUSTL(LOC_CPACKING)) ) - CASE ( 'grib-simple' ) + CASE ( 'simple' ) IPACKING = PACKING_GRIB_SIMPLE_E - CASE ( 'grib-ccsds' ) + CASE ( 'ccsds' ) IPACKING = PACKING_GRIB_CCSDS_E - CASE ( 'grib-complex' ) + CASE ( 'complex' ) IPACKING = PACKING_GRIB_COMPLEX_E CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_PACKING ) diff --git a/src/multiom/common/log_info_mod.F90 b/src/multiom/common/log_info_mod.F90 index 4294253cd..9bd667cca 100644 --- a/src/multiom/common/log_info_mod.F90 +++ b/src/multiom/common/log_info_mod.F90 @@ -105,7 +105,7 @@ PP_THREAD_SAFE FUNCTION LOG_SYSINFO( LOGUNIT, NPROCSIO, MYPROCIO, HOOKS ) RESULT PP_DEBUG_CRITICAL_COND_THROW( STAT .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) WRITE(LOGUNIT,'(A,A)', IOSTAT=STAT) ' + HOSTNAME............: ', TRIM(ADJUSTL(HOSTNAME)) PP_DEBUG_CRITICAL_COND_THROW( STAT .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) - WRITE(LOGUNIT,'(A,I8)', IOSTAT=STAT) ' + PID.................: ', TRIM(ADJUSTL(CPID)) + WRITE(LOGUNIT,'(A,A)', IOSTAT=STAT) ' + PID.................: ', TRIM(ADJUSTL(CPID)) PP_DEBUG_CRITICAL_COND_THROW( STAT .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) ! Trace end of procedure (on success) diff --git a/src/multiom/data-structures/mars/fortran_message_enumerators_mod.F90 b/src/multiom/data-structures/mars/fortran_message_enumerators_mod.F90 index af5b4241a..31cdd21ba 100644 --- a/src/multiom/data-structures/mars/fortran_message_enumerators_mod.F90 +++ b/src/multiom/data-structures/mars/fortran_message_enumerators_mod.F90 @@ -41,7 +41,8 @@ MODULE FORTRAN_MESSAGE_ENUMERATORS_MOD INTEGER(KIND=JPIB_K), PARAMETER :: MSGINTFLD_TIME_E=20_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: MSGINTFLD_STEP_E=21_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: MSGINTFLD_PACKING_E=22_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: N_MSGINTFLDS=22_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: MSGINTFLD_TRUNCATION_E=23_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: N_MSGINTFLDS=23_JPIB_K ! String enumerators INTEGER(KIND=JPIB_K), PARAMETER :: MSGSTRFLD_EXPVER_E=101_JPIB_K @@ -77,6 +78,7 @@ MODULE FORTRAN_MESSAGE_ENUMERATORS_MOD PUBLIC :: MSGINTFLD_TIME_E PUBLIC :: MSGINTFLD_STEP_E PUBLIC :: MSGINTFLD_PACKING_E + PUBLIC :: MSGINTFLD_TRUNCATION_E PUBLIC :: N_MSGINTFLDS ! String enumerators @@ -199,6 +201,8 @@ PP_THREAD_SAFE FUNCTION IMSGINTFLDS2CMSGINTFLDS( IMSGINTFLDS, CMSGINTFLDS, HOOKS CMSGINTFLDS = 'step' CASE (MSGINTFLD_PACKING_E) CMSGINTFLDS = 'packing' + CASE (MSGINTFLD_TRUNCATION_E) + CMSGINTFLDS = 'truncation' CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_MSGINTFLD_UNARY ) END SELECT @@ -357,6 +361,8 @@ PP_THREAD_SAFE FUNCTION CMSGINTFLDS2IMSGINTFLDS( CMSGINTFLDS, IMSGINTFLDS, HOOKS IMSGINTFLDS = MSGINTFLD_STEP_E CASE( 'packing' ) IMSGINTFLDS = MSGINTFLD_PACKING_E + CASE ( 'truncation' ) + IMSGINTFLDS = MSGINTFLD_TRUNCATION_E CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_MSGINTFLD_UNARY ) END SELECT diff --git a/src/multiom/data-structures/mars/fortran_message_mod.F90 b/src/multiom/data-structures/mars/fortran_message_mod.F90 index 39970b194..33ae03211 100644 --- a/src/multiom/data-structures/mars/fortran_message_mod.F90 +++ b/src/multiom/data-structures/mars/fortran_message_mod.F90 @@ -46,6 +46,7 @@ MODULE FORTRAN_MESSAGE_MOD !> Field information INTEGER(KIND=JPIB_K) :: PARAM_TYPE = UNDEF_PARAM_E + ! INTEGER(KIND=JPIB_K), DIMENSION(2) :: WAVELENGTH = [UNDEF_PARAM_E, UNDEF_PARAM_E] INTEGER(KIND=JPIB_K) :: CHEM = UNDEF_PARAM_E INTEGER(KIND=JPIB_K) :: PARAM = UNDEF_PARAM_E INTEGER(KIND=JPIB_K) :: MODEL = UNDEF_PARAM_E !! Deprecated @@ -67,6 +68,8 @@ MODULE FORTRAN_MESSAGE_MOD !> Grid information INTEGER(KIND=JPIB_K) :: REPRES = UNDEF_PARAM_E CHARACTER(LEN=8) :: GRID = REPEAT('*',8) + INTEGER(KIND=JPIB_K) :: TRUNCATION = UNDEF_PARAM_E + ! INTEGER(KIND=JPIB_K), DIMENSION(2) :: ROTATION = [UNDEF_PARAM_E, UNDEF_PARAM_E] CONTAINS @@ -116,6 +119,7 @@ MODULE FORTRAN_MESSAGE_MOD !> Set fields by field ID PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: PRINT => FORTRAN_MESSAGE_PRINT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: TO_JSON => FORTRAN_MESSAGE_TO_JSON + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => FORTRAN_MESSAGE_TO_YAML END TYPE @@ -174,6 +178,7 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_INIT( THIS, HOOKS ) RESULT(RET) THIS%CLASS = UNDEF_PARAM_E THIS%ORIGIN = UNDEF_PARAM_E THIS%ANOFFSET = UNDEF_PARAM_E + THIS%PACKING = UNDEF_PARAM_E THIS%NUMBER = UNDEF_PARAM_E THIS%IDENT = UNDEF_PARAM_E THIS%INSTRUMENT = UNDEF_PARAM_E @@ -181,15 +186,16 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_INIT( THIS, HOOKS ) RESULT(RET) THIS%PARAM_TYPE = UNDEF_PARAM_E THIS%CHEM = UNDEF_PARAM_E THIS%PARAM = UNDEF_PARAM_E + THIS%MODEL = UNDEF_PARAM_E THIS%LEVTYPE = UNDEF_PARAM_E THIS%LEVELIST = UNDEF_PARAM_E THIS%DIRECTION = UNDEF_PARAM_E THIS%FREQUENCY = UNDEF_PARAM_E - THIS%MODEL = UNDEF_PARAM_E - THIS%REPRES = UNDEF_PARAM_E THIS%DATE = UNDEF_PARAM_E THIS%TIME = UNDEF_PARAM_E THIS%STEP = UNDEF_PARAM_E + THIS%REPRES = UNDEF_PARAM_E + THIS%TRUNCATION = UNDEF_PARAM_E !> String members THIS%TIMEPROC = REPEAT('*',8) @@ -291,6 +297,7 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_FREE( THIS, HOOKS ) RESULT(RET) THIS%CLASS = UNDEF_PARAM_E THIS%ORIGIN = UNDEF_PARAM_E THIS%ANOFFSET = UNDEF_PARAM_E + THIS%PACKING = UNDEF_PARAM_E THIS%NUMBER = UNDEF_PARAM_E THIS%IDENT = UNDEF_PARAM_E THIS%INSTRUMENT = UNDEF_PARAM_E @@ -298,15 +305,16 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_FREE( THIS, HOOKS ) RESULT(RET) THIS%PARAM_TYPE = UNDEF_PARAM_E THIS%CHEM = UNDEF_PARAM_E THIS%PARAM = UNDEF_PARAM_E + THIS%MODEL = UNDEF_PARAM_E THIS%LEVTYPE = UNDEF_PARAM_E THIS%LEVELIST = UNDEF_PARAM_E THIS%DIRECTION = UNDEF_PARAM_E THIS%FREQUENCY = UNDEF_PARAM_E - THIS%MODEL = UNDEF_PARAM_E - THIS%REPRES = UNDEF_PARAM_E THIS%DATE = UNDEF_PARAM_E THIS%TIME = UNDEF_PARAM_E THIS%STEP = UNDEF_PARAM_E + THIS%REPRES = UNDEF_PARAM_E + THIS%TRUNCATION = UNDEF_PARAM_E THIS%TIMEPROC = REPEAT('*',8) THIS%EXPVER = REPEAT('*',4) @@ -362,17 +370,20 @@ END FUNCTION FORTRAN_MESSAGE_FREE PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_PRINT( THIS, UNIT, HOOKS ) RESULT(RET) !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T - USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGINTFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGINTFLDS2CMSGINTFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGSTRFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGSTRINGFLDS2CMSGSTRINGFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGFLOATFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGFLOATFLDS2CMSGFLOATFLDS + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + USE :: ENUMERATORS_MOD, ONLY: IPARAMTYPE2CPARAMTYPE + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + USE :: DATETIME_UTILS_MOD, ONLY: HHMMSS2STRING + USE :: DATETIME_UTILS_MOD, ONLY: YYYYMMDD2STRING ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -394,28 +405,20 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_PRINT( THIS, UNIT, HOOKS ) RESULT(RET) INTEGER(KIND=JPIB_K) :: RET !> Local parameters - INTEGER(KIND=JPIB_K) :: I - INTEGER(KIND=JPIB_K) :: ITMP - REAL(KIND=JPRD_K) :: RTMP - CHARACTER(LEN=16) :: CKEY - CHARACTER(LEN=8) :: CTMP + CHARACTER(LEN=32) :: CTMP INTEGER(KIND=JPIB_K) :: WRITE_STAT - LOGICAL :: HAS_FIELD !> Local error flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGINTFLDS2CMSGINTFLDS=1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_INT=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_STRING=4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGFLOATFLDS2CMSGFLOATFLDS=5_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_FLOAT=6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=7_JPIB_K - - - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_INT=8_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_STRING=9_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_FLOAT=10_JPIB_K - + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ISTREAM2CSTREAM=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ITYPE2CTYPE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ICLASS2CCLASS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPACKING2CPACKING=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPARAMTYPE2CPARAMTYPE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ILEVTYPE2CLEVTYPE=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IREPRES2CREPRES=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DATE_TO_STRING=9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIME_TO_STRING=10_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -435,47 +438,182 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_PRINT( THIS, UNIT, HOOKS ) RESULT(RET) WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) '** MESSAGE PRINT' PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) - ! Integer members - IF ( N_MSGINTFLDS .GT. 0 ) THEN - WRITE(UNIT,*) '+ Integer members' - DO I = 1, N_MSGINTFLDS - PP_TRYCALL(ERRFLAG_HAS_INT) THIS%HAS_ENUM( I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - PP_TRYCALL(ERRFLAG_IMSGINTFLDS2CMSGINTFLDS) IMSGINTFLDS2CMSGINTFLDS( I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_INT) THIS%GET_ENUM_INT( I, ITMP, HOOKS ) - IF ( ITMP .NE. UNDEF_PARAM_E ) THEN - WRITE(UNIT,'(A3,A20,A3,I32)',IOSTAT=WRITE_STAT) ' - ', TRIM(ADJUSTL(CKEY)) ,' : ', ITMP - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) - ENDIF - ENDIF - ENDDO - ENDIF - - ! String members - IF ( N_MSGSTRFLDS .GT. 0 ) THEN - WRITE(UNIT,*) '+ String members' - DO I = 1, N_MSGSTRFLDS - PP_TRYCALL(ERRFLAG_HAS_STRING) THIS%HAS_ENUM( 100_JPIB_K + I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - PP_TRYCALL(ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS) IMSGSTRINGFLDS2CMSGSTRINGFLDS( 100_JPIB_K + I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_STRING) THIS%GET_ENUM_STRING( 100_JPIB_K + I, CTMP, HOOKS ) - WRITE(UNIT,'(A3,A20,A3,A8)',IOSTAT=WRITE_STAT) ' - ', TRIM(ADJUSTL(CKEY)) ,' : ', CTMP - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) - ENDIF - ENDDO - ENDIF - - ! Float members - IF ( N_MSGFLOATFLDS .GT. 0 ) THEN - WRITE(UNIT,*) '+ Float members' - DO I = 1, N_MSGFLOATFLDS - PP_TRYCALL(ERRFLAG_IMSGFLOATFLDS2CMSGFLOATFLDS) IMSGFLOATFLDS2CMSGFLOATFLDS( 200_JPIB_K + I, CKEY, HOOKS ) - IF ( HAS_FIELD ) THEN - PP_TRYCALL(ERRFLAG_GET_FLOAT) THIS%GET_ENUM_FLOAT( 200_JPIB_K + I, RTMP, HOOKS ) - WRITE(UNIT,'(A3,A20,A3,F11.4)',IOSTAT=WRITE_STAT) ' - ', TRIM(ADJUSTL(CKEY)) ,' : ', RTMP - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) - ENDIF - ENDDO + ! Print Stream + IF ( THIS%STREAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ISTREAM2CSTREAM) ISTREAM2CSTREAM( THIS%STREAM, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - STREAM......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Type + IF ( THIS%TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ITYPE2CTYPE) ITYPE2CTYPE( THIS%TYPE, CTMP, HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - TYPE........: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Class + IF ( THIS%CLASS .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ICLASS2CCLASS) ICLASS2CCLASS( THIS%CLASS, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - CLASS.......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Expver + IF ( THIS%EXPVER .NE. '****' ) THEN + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - EXPVER......: ', TRIM(ADJUSTL(THIS%EXPVER)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PACKING + IF ( THIS%PACKING .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPACKING2CPACKING) IPACKING2CPACKING( THIS%PACKING, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - PACKING.....: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print NUMBER + IF ( THIS%NUMBER .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%NUMBER + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - NUMBER......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print IDENT + IF ( THIS%IDENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%IDENT + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - IDENT.......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print INSTRUMENT + IF ( THIS%INSTRUMENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%INSTRUMENT + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - INSTRUMENT..: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print CHANNEL + IF ( THIS%CHANNEL .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHANNEL + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - CHANNEL.....: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PARAM_TYPE + IF ( THIS%PARAM_TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPARAMTYPE2CPARAMTYPE) IPARAMTYPE2CPARAMTYPE( THIS%PARAM_TYPE, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - PARAM_TYPE..: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print CHEM + IF ( THIS%CHEM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHEM + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - CHEM......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PARAM + IF ( THIS%PARAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%PARAM + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - PARAM......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print LEVTYPE + IF ( THIS%LEVTYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) ILEVTYPE2CLEVTYPE( THIS%LEVTYPE, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - LEVTYPE.....: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print LEVELIST + IF ( THIS%LEVELIST .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%LEVELIST + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - LEVELIST....: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print DIRECTION + IF ( THIS%DIRECTION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%DIRECTION + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - DIRECTION...: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print FREQUENCY + IF ( THIS%FREQUENCY .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%FREQUENCY + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - FREQUENCY...: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print DATE + IF ( THIS%DATE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_DATE_TO_STRING) YYYYMMDD2STRING( THIS%DATE, CTMP(1:10), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - DATE...: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TIME + IF ( THIS%TIME .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_TIME_TO_STRING) HHMMSS2STRING( THIS%TIME, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - TIME...: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print STEP + IF ( THIS%STEP .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%STEP + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - STEP...: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TIMEPROC + IF ( THIS%TIMEPROC .NE. '********' ) THEN + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - TIMEPROC....: ', TRIM(ADJUSTL(THIS%TIMEPROC)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print REPRES + IF ( THIS%REPRES .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) IREPRES2CREPRES( THIS%REPRES, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - REPRES......: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print GRID + IF ( THIS%GRID .NE. '********' ) THEN + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - GRID........: ', TRIM(ADJUSTL(THIS%GRID)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TRUNCATION + IF ( THIS%TRUNCATION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%TRUNCATION + WRITE(UNIT,'(A,A)',IOSTAT=WRITE_STAT) ' - TRUNCATION..: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) ENDIF ! Trace end of procedure (on success) @@ -500,16 +638,10 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_PRINT( THIS, UNIT, HOOKS ) RESULT(RET) ! Handle different errors SELECT CASE(ERRIDX) - CASE(ERRFLAG_IMSGINTFLDS2CMSGINTFLDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert integer field ID to string' ) - CASE(ERRFLAG_GET_INT) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get integer field' ) - CASE(ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert string field ID to string' ) - CASE(ERRFLAG_GET_STRING) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get string field' ) - CASE(ERRFLAG_IOSTATUS_NOT_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'IO status is not zero' ) + CASE (ERRFLAG_DATE_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'YYYYMMDD2STRING failed' ) + CASE (ERRFLAG_TIME_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'HHMMSS2STRING failed' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) END SELECT @@ -535,19 +667,23 @@ END FUNCTION FORTRAN_MESSAGE_PRINT #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'FORTRAN_MESSAGE_TO_JSON' -PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_JSON( THIS, JSON, HOOKS ) RESULT(RET) +PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_JSON( THIS, OUT_JSON, HOOKS ) RESULT(RET) !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGINTFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGINTFLDS2CMSGINTFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGSTRFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGSTRINGFLDS2CMSGSTRINGFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: N_MSGFLOATFLDS - USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGFLOATFLDS2CMSGFLOATFLDS + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + USE :: ENUMERATORS_MOD, ONLY: IPARAMTYPE2CPARAMTYPE + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + USE :: DATETIME_UTILS_MOD, ONLY: HHMMSS2STRING + USE :: DATETIME_UTILS_MOD, ONLY: YYYYMMDD2STRING ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -562,46 +698,38 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_JSON( THIS, JSON, HOOKS ) RESULT(RET) !> Dummy arguments CLASS(FORTRAN_MESSAGE_T), INTENT(INOUT) :: THIS - CHARACTER(LEN=:), ALLOCATABLE, INTENT(INOUT) :: JSON + CHARACTER(LEN=:), ALLOCATABLE, INTENT(INOUT) :: OUT_JSON TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET - !> Local parameters - INTEGER(KIND=JPIB_K) :: L + !> Local variables + CHARACTER(LEN=32) :: CTMP + CHARACTER(LEN=128), DIMENSION(32) :: JSON INTEGER(KIND=JPIB_K) :: I - INTEGER(KIND=JPIB_K) :: SZ + INTEGER(KIND=JPIB_K) :: CNT INTEGER(KIND=JPIB_K) :: LO INTEGER(KIND=JPIB_K) :: HI - INTEGER(KIND=JPIB_K) :: CNT - INTEGER(KIND=JPIB_K) :: N_FIELDS - INTEGER(KIND=JPIB_K) :: ITMP - REAL(KIND=JPRD_K) :: RTMP - CHARACTER(LEN=16) :: CKEY - CHARACTER(LEN=32) :: CTMP - CHARACTER(LEN=1024) :: JSON_ITEM - CHARACTER(LEN=1) :: SEP + INTEGER(KIND=JPIB_K) :: ALLOC_STAT INTEGER(KIND=JPIB_K) :: WRITE_STAT - INTEGER(KIND=JPIB_K) :: ALLOC_STATE - INTEGER(KIND=JPIB_K) :: DEALLOC_STATE + INTEGER(KIND=JPIB_K) :: TOTLEN + CHARACTER(LEN=2) :: SEP CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG - LOGICAL :: HAS_FIELD - !> Local error flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGINTFLDS2CMSGINTFLDS=1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_INT=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_STRING=4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IMSGFLOATFLDS2CMSGFLOATFLDS=5_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GET_FLOAT=6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ALLOC_ERROR=7_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DEALLOC_ERROR=8_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=9_JPIB_K - - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_INT=10_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_STRING=11_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_HAS_FLOAT=12_JPIB_K + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ISTREAM2CSTREAM=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ITYPE2CTYPE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ICLASS2CCLASS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPACKING2CPACKING=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPARAMTYPE2CPARAMTYPE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ILEVTYPE2CLEVTYPE=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IREPRES2CREPRES=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS=9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ALLOCATE=10_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DATE_TO_STRING=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIME_TO_STRING=12_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -618,163 +746,257 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_JSON( THIS, JSON, HOOKS ) RESULT(RET) ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - CNT = 0 - N_FIELDS = N_MSGINTFLDS + N_MSGSTRFLDS + N_MSGFLOATFLDS - - ! Count the number of characters needed for the JSON string - SZ = 9 - LO = 1 - HI = LO + SZ - 1 - IF ( N_MSGINTFLDS .GT. 0 ) THEN - DO I = 1, N_MSGINTFLDS - PP_TRYCALL(ERRFLAG_HAS_INT) THIS%HAS_ENUM( I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGINTFLDS2CMSGINTFLDS) IMSGINTFLDS2CMSGINTFLDS( I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_INT) THIS%GET_ENUM_INT( I, ITMP, HOOKS ) - WRITE(CTMP,*,IOSTAT=WRITE_STAT) ITMP - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 1 - LO = HI + 1 - HI = LO + SZ - 1 - ENDIF - ENDDO - ENDIF - - ! String members - IF ( N_MSGSTRFLDS .GT. 0 ) THEN - DO I = 1, N_MSGSTRFLDS - PP_TRYCALL(ERRFLAG_HAS_STRING) THIS%HAS_ENUM( 100_JPIB_K + I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS) IMSGSTRINGFLDS2CMSGSTRINGFLDS( 100_JPIB_K + I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_STRING) THIS%GET_ENUM_STRING( 100_JPIB_K + I, CTMP, HOOKS ) - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 3 - LO = HI + 1 - HI = LO + SZ - 1 - ENDIF - ENDDO - ENDIF - - ! Float members - IF ( N_MSGFLOATFLDS .GT. 0 ) THEN - DO I = 1, N_MSGFLOATFLDS - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGFLOATFLDS2CMSGFLOATFLDS) IMSGFLOATFLDS2CMSGFLOATFLDS( 200_JPIB_K + I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_FLOAT) THIS%GET_ENUM_FLOAT( I, RTMP, HOOKS ) - WRITE(CTMP,*,IOSTAT=WRITE_STAT) RTMP - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 1 - LO = HI + 1 - HI = LO + SZ - 1 - ENDDO - ENDIF - - ! Close the JSON object - ! Size equal to one for the closing bracket no null character is needed - ! since it is alreday include in the string - SZ = 1 - LO = HI + 1 - HI = LO + SZ ! + 1 - - ! Free the json string - IF ( ALLOCATED(JSON) ) THEN - DEALLOCATE(JSON, STAT=DEALLOC_STATE, ERRMSG=ERRMSG) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATE .NE. 0, ERRFLAG_DEALLOC_ERROR ) - ENDIF - - ! Allocate the JSON string - L = HI - ALLOCATE(CHARACTER(LEN=L) :: JSON, STAT=ALLOC_STATE, ERRMSG=ERRMSG) - PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STATE .NE. 0, ERRFLAG_ALLOC_ERROR ) - - ! Fill the JSON string - JSON = REPEAT(' ', L) - SZ = 9 - LO = 1 - HI = LO + SZ - 1 - JSON(LO:HI) = 'message={' - IF ( N_MSGINTFLDS .GT. 0 ) THEN - DO I = 1, N_MSGINTFLDS - PP_TRYCALL(ERRFLAG_HAS_INT) THIS%HAS_ENUM( I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - CNT = CNT + 1 - IF ( CNT .GE. N_FIELDS ) THEN - SEP = ' ' - ELSE - SEP = ',' - ENDIF - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGINTFLDS2CMSGINTFLDS) IMSGINTFLDS2CMSGINTFLDS( I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_INT) THIS%GET_ENUM_INT( I, ITMP, HOOKS ) - WRITE(CTMP,*,IOSTAT=WRITE_STAT) ITMP - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 1 - LO = HI + 1 - HI = LO + SZ - 1 - JSON_ITEM = REPEAT(' ', 1024) - WRITE(JSON_ITEM, '(A1,A,A1,A,A1)') ' ', TRIM(ADJUSTL(CKEY)) ,':', TRIM(ADJUSTL(CTMP)), SEP - JSON(LO:HI) = TRIM(JSON_ITEM) - ENDIF - ENDDO - ENDIF - - ! String members - IF ( N_MSGSTRFLDS .GT. 0 ) THEN - DO I = 1, N_MSGSTRFLDS - PP_TRYCALL(ERRFLAG_HAS_STRING) THIS%HAS_ENUM( 100_JPIB_K+I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - CNT = CNT + 1 - IF ( CNT .GE. N_FIELDS ) THEN - SEP = ' ' - ELSE - SEP = ',' - ENDIF - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS) IMSGSTRINGFLDS2CMSGSTRINGFLDS( 100_JPIB_K + I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_STRING) THIS%GET_ENUM_STRING( 100_JPIB_K + I, CTMP, HOOKS ) - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 3 - LO = HI + 1 - HI = LO + SZ - 1 - JSON_ITEM = REPEAT(' ', 1024) - WRITE(JSON_ITEM, '(A1,A,A2,A,A1,A1)') ' ', TRIM(ADJUSTL(CKEY)) ,':"', TRIM(ADJUSTL(CTMP)), '"', SEP - JSON(LO:HI) = TRIM(JSON_ITEM) - ENDIF - ENDDO - ENDIF - - ! Float members - IF ( N_MSGFLOATFLDS .GT. 0 ) THEN - DO I = 1, N_MSGFLOATFLDS - PP_TRYCALL(ERRFLAG_HAS_STRING) THIS%HAS_ENUM( I, HAS_FIELD, HOOKS ) - IF ( HAS_FIELD ) THEN - CNT = CNT + 1 - IF ( CNT .GE. N_FIELDS ) THEN - SEP = ' ' - ELSE - SEP = ',' - ENDIF - CTMP=REPEAT(' ',32) - CKEY=REPEAT(' ',16) - PP_TRYCALL(ERRFLAG_IMSGFLOATFLDS2CMSGFLOATFLDS) IMSGFLOATFLDS2CMSGFLOATFLDS( I, CKEY, HOOKS ) - PP_TRYCALL(ERRFLAG_GET_FLOAT) THIS%GET_ENUM_FLOAT( I, RTMP, HOOKS ) - WRITE(CTMP,*,IOSTAT=WRITE_STAT) RTMP - SZ = 1 + LEN_TRIM(ADJUSTL(CKEY)) + 1 + LEN_TRIM(ADJUSTL(CTMP)) + 1 - LO = HI + 1 - HI = LO + SZ - 1 - JSON_ITEM = REPEAT(' ', 1024) - WRITE(JSON_ITEM, '(A1,A,A1,A,A1)') ' ', TRIM(ADJUSTL(CKEY)) ,':', TRIM(ADJUSTL(CTMP)), SEP - JSON(LO:HI) = TRIM(JSON_ITEM) - ENDIF - ENDDO + ! Initialization + CNT = 0_JPIB_K + TOTLEN = 8_JPIB_K + + ! Print Stream + IF ( THIS%STREAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ISTREAM2CSTREAM) ISTREAM2CSTREAM( THIS%STREAM, CTMP(1:8), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"stream":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print Type + IF ( THIS%TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ITYPE2CTYPE) ITYPE2CTYPE( THIS%TYPE, CTMP, HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"stream":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print Class + IF ( THIS%CLASS .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ICLASS2CCLASS) ICLASS2CCLASS( THIS%CLASS, CTMP(1:8), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"class":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print Expver + IF ( THIS%EXPVER .NE. '****' ) THEN + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"expver":"'//TRIM(ADJUSTL(THIS%EXPVER))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print PACKING + IF ( THIS%PACKING .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPACKING2CPACKING) IPACKING2CPACKING( THIS%PACKING, CTMP(1:16), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"packing":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print NUMBER + IF ( THIS%NUMBER .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%NUMBER + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"ident":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print IDENT + IF ( THIS%IDENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%IDENT + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"ident":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print INSTRUMENT + IF ( THIS%INSTRUMENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%INSTRUMENT + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"instrument":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print CHANNEL + IF ( THIS%CHANNEL .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHANNEL + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"channel":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print PARAM_TYPE + IF ( THIS%PARAM_TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPARAMTYPE2CPARAMTYPE) IPARAMTYPE2CPARAMTYPE( THIS%PARAM_TYPE, CTMP(1:16), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"paramtype":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print CHEM + IF ( THIS%CHEM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHEM + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"chem":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print PARAM + IF ( THIS%PARAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%PARAM + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"param":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print LEVTYPE + IF ( THIS%LEVTYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) ILEVTYPE2CLEVTYPE( THIS%LEVTYPE, CTMP(1:16), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"levtype":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print LEVELIST + IF ( THIS%LEVELIST .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%LEVELIST + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"levelist":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print DIRECTION + IF ( THIS%DIRECTION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%DIRECTION + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"direction":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print FREQUENCY + IF ( THIS%FREQUENCY .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%FREQUENCY + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"frequency":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print DATE + IF ( THIS%DATE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_DATE_TO_STRING) YYYYMMDD2STRING( THIS%DATE, CTMP(1:10), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"date":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print TIME + IF ( THIS%TIME .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_TIME_TO_STRING) HHMMSS2STRING( THIS%TIME, CTMP(1:8), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"time":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print STEP + IF ( THIS%STEP .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%STEP + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"step":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print TIMEPROC + IF ( THIS%TIMEPROC .NE. '********' ) THEN + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"timeproc":"'//TRIM(ADJUSTL(THIS%TIMEPROC))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print REPRES + IF ( THIS%REPRES .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IREPRES2CREPRES) IREPRES2CREPRES( THIS%REPRES, CTMP(1:16), HOOKS ) + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"repres":"'//TRIM(ADJUSTL(CTMP))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Print GRID + IF ( THIS%GRID .NE. '********' ) THEN + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"grid":"'//TRIM(ADJUSTL(THIS%GRID))//'"' + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 ENDIF - ! Close the JSON object - LO = LEN_TRIM(JSON) - HI = LO + 2 - JSON(LO:HI) = ' };' + ! Print TRUNCATION + IF ( THIS%TRUNCATION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%TRUNCATION + CNT = CNT + 1 + JSON(CNT) = REPEAT(' ',128) + JSON(CNT) = '"truncation":'//TRIM(ADJUSTL(CTMP)) + TOTLEN = TOTLEN + LEN(TRIM(ADJUSTL(JSON(CNT)))) + 2 + ENDIF + + ! Add the final parenthesis + TOTLEN = TOTLEN + 2_JPIB_K + + ! Allocate the output JSON string + ALLOCATE( CHARACTER(LEN=TOTLEN)::OUT_JSON, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_ALLOCATE ) + + ! Concatenate the JSON strings to a single string + LO=1_JPIB_K + HI=8_JPIB_K + OUT_JSON = REPEAT( ' ', TOTLEN ) + OUT_JSON(1:8) = 'message:' + SEP='{ ' + DO I = 1, CNT + LO=HI+1 + HI=LO+LEN(TRIM(ADJUSTL(JSON(I))))+1 + PP_DEBUG_CRITICAL_COND_THROW( HI.GT.TOTLEN, ERRFLAG_OUT_OF_BOUNDS ) + OUT_JSON(LO:HI) = SEP//TRIM(ADJUSTL(JSON(I))) + SEP=', ' + ENDDO + LO=HI+1 + HI=LO+2-1 + OUT_JSON(LO:HI) = ' }' ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -798,28 +1020,34 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_JSON( THIS, JSON, HOOKS ) RESULT(RET) ! Handle different errors SELECT CASE(ERRIDX) - CASE(ERRFLAG_IMSGINTFLDS2CMSGINTFLDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert integer field ID to string' ) - CASE(ERRFLAG_GET_INT) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get integer field' ) - CASE(ERRFLAG_IMSGSTRINGFLDS2CMSGSTRINGFLDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert string field ID to string' ) - CASE(ERRFLAG_GET_STRING) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get string field' ) - CASE(ERRFLAG_IOSTATUS_NOT_ZERO) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'IO status is not zero' ) - CASE(ERRFLAG_ALLOC_ERROR) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Allocation error' ) + CASE (ERRFLAG_IOSTATUS_NOT_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'I/O status not zero' ) + CASE (ERRFLAG_ISTREAM2CSTREAM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ISTREAM2CSTREAM failed' ) + CASE (ERRFLAG_ITYPE2CTYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ITYPE2CTYPE failed' ) + CASE (ERRFLAG_ICLASS2CCLASS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ICLASS2CCLASS failed' ) + CASE (ERRFLAG_IPACKING2CPACKING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'IPACKING2CPACKING failed' ) + CASE (ERRFLAG_IPARAMTYPE2CPARAMTYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'IPARAMTYPE2CPARAMTYPE failed' ) + CASE (ERRFLAG_ILEVTYPE2CLEVTYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ILEVTYPE2CLEVTYPE failed' ) + CASE (ERRFLAG_IREPRES2CREPRES) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'IREPRES2CREPRES failed' ) + CASE (ERRFLAG_OUT_OF_BOUNDS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Out of bounds' ) + CASE (ERRFLAG_UNABLE_TO_ALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to allocate' ) IF ( ALLOCATED(ERRMSG) ) THEN - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//ERRMSG ) - DEALLOCATE( ERRMSG, STAT=DEALLOC_STATE ) - ENDIF - CASE(ERRFLAG_DEALLOC_ERROR) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Deallocation error' ) - IF ( ALLOCATED(ERRMSG) ) THEN - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//ERRMSG ) - DEALLOCATE( ERRMSG, STAT=DEALLOC_STATE ) - ENDIF + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE( ERRMSG, STAT=ALLOC_STAT ) + END IF + CASE (ERRFLAG_DATE_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'YYYYMMDD2STRING failed' ) + CASE (ERRFLAG_TIME_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'HHMMSS2STRING failed' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) END SELECT @@ -893,24 +1121,34 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_COPY_DATA_FROM( THIS, OTHER, HOOKS ) RES THIS%EXPVER = OTHER%EXPVER THIS%ORIGIN = OTHER%ORIGIN THIS%ANOFFSET = OTHER%ANOFFSET + + THIS%PACKING = OTHER%PACKING + THIS%NUMBER = OTHER%NUMBER + THIS%IDENT = OTHER%IDENT THIS%INSTRUMENT = OTHER%INSTRUMENT THIS%CHANNEL = OTHER%CHANNEL + THIS%PARAM_TYPE = OTHER%PARAM_TYPE THIS%CHEM = OTHER%CHEM THIS%PARAM = OTHER%PARAM + THIS%MODEL = OTHER%MODEL + THIS%LEVTYPE = OTHER%LEVTYPE THIS%LEVELIST = OTHER%LEVELIST + THIS%DIRECTION = OTHER%DIRECTION THIS%FREQUENCY = OTHER%FREQUENCY - THIS%MODEL = OTHER%MODEL - THIS%REPRES = OTHER%REPRES + THIS%DATE = OTHER%DATE THIS%TIME = OTHER%TIME THIS%STEP = OTHER%STEP + + THIS%TIMEPROC = OTHER%TIMEPROC + THIS%REPRES = OTHER%REPRES THIS%GRID = OTHER%GRID - THIS%PACKING = OTHER%PACKING + THIS%TRUNCATION = OTHER%TRUNCATION ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1031,6 +1269,14 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%ANOFFSET = OTHER%ANOFFSET OTHER%ANOFFSET = ITMP + + + ITMP = THIS%PACKING + THIS%PACKING = OTHER%PACKING + OTHER%PACKING = ITMP + + + ITMP = THIS%NUMBER THIS%NUMBER = OTHER%NUMBER OTHER%NUMBER = ITMP @@ -1047,6 +1293,8 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%CHANNEL = OTHER%CHANNEL OTHER%CHANNEL = ITMP + + ITMP = THIS%PARAM_TYPE THIS%PARAM_TYPE = OTHER%PARAM_TYPE OTHER%PARAM_TYPE = ITMP @@ -1059,6 +1307,12 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%PARAM = OTHER%PARAM OTHER%PARAM = ITMP + ITMP = THIS%MODEL + THIS%MODEL = OTHER%MODEL + OTHER%MODEL =ITMP + + + ITMP = THIS%LEVTYPE THIS%LEVTYPE = OTHER%LEVTYPE OTHER%LEVTYPE = ITMP @@ -1067,6 +1321,8 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%LEVELIST = OTHER%LEVELIST OTHER%LEVELIST = ITMP + + ITMP = THIS%DIRECTION THIS%DIRECTION = OTHER%DIRECTION OTHER%DIRECTION = ITMP @@ -1075,13 +1331,7 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%FREQUENCY = OTHER%FREQUENCY OTHER%FREQUENCY = ITMP - ITMP = THIS%MODEL - THIS%MODEL = OTHER%MODEL - OTHER%MODEL =ITMP - ITMP = THIS%REPRES - THIS%REPRES = OTHER%REPRES - OTHER%REPRES = ITMP ITMP = THIS%DATE THIS%DATE = OTHER%DATE @@ -1095,13 +1345,25 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SWAP_DATA( THIS, OTHER, OPT, HOOKS ) RES THIS%STEP = OTHER%STEP OTHER%STEP = ITMP + CTMP8 = THIS%TIMEPROC + THIS%TIMEPROC = OTHER%TIMEPROC + OTHER%TIMEPROC = CTMP8 + + + + + ITMP = THIS%REPRES + THIS%REPRES = OTHER%REPRES + OTHER%REPRES = ITMP + CTMP8 = THIS%GRID THIS%GRID = OTHER%GRID OTHER%GRID = CTMP8 - ITMP = THIS%PACKING - THIS%PACKING = OTHER%PACKING - OTHER%PACKING = ITMP + ITMP = THIS%TRUNCATION + THIS%TRUNCATION = OTHER%TRUNCATION + OTHER%TRUNCATION = ITMP + ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1237,14 +1499,16 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_EQUAL_TO( THIS, OTHER, OPT, IS_EQUAL, HO ! Time information should never be cached !IF ( OPT%CACHE_TIME_RELATED_INFO ) THEN - IS_EQUAL = IS_EQUAL .AND. ( THIS%DATE .EQ. OTHER%DATE ) - IS_EQUAL = IS_EQUAL .AND. ( THIS%TIME .EQ. OTHER%TIME ) - IS_EQUAL = IS_EQUAL .AND. ( THIS%STEP .EQ. OTHER%STEP ) + ! IS_EQUAL = IS_EQUAL .AND. ( THIS%DATE .EQ. OTHER%DATE ) + ! IS_EQUAL = IS_EQUAL .AND. ( THIS%TIME .EQ. OTHER%TIME ) + ! IS_EQUAL = IS_EQUAL .AND. ( THIS%STEP .EQ. OTHER%STEP ) + ! IS_EQUAL = IS_EQUAL .AND. ( THIS%TIMEPROC .EQ. OTHER%TIMEPROC ) !ENDIF !IF ( OPT%CACHE_GRID_DEFINITION_INFO ) THEN IS_EQUAL = IS_EQUAL .AND. ( THIS%REPRES .EQ. OTHER%REPRES ) IS_EQUAL = IS_EQUAL .AND. ( THIS%GRID .EQ. OTHER%GRID ) + IS_EQUAL = IS_EQUAL .AND. ( THIS%TRUNCATION .EQ. OTHER%TRUNCATION ) !ENDIF ! Trace end of procedure (on success) @@ -1384,11 +1648,13 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_LOWER_THAN( THIS, OTHER, OPT, IS_LOWER_T ! IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%DATE .LT. OTHER%DATE ) ! IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%TIME .LT. OTHER%TIME ) ! IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%STEP .LT. OTHER%STEP ) + ! IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%TIMEPROC .LT. OTHER%TIMEPROC ) ! ENDIF ! IF ( OPT%CACHE_GRID_DEFINITION_INFO ) THEN IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%REPRES .LT. OTHER%REPRES ) IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%GRID .LT. OTHER%GRID ) + IS_LOWER_THAN = IS_LOWER_THAN .AND. ( THIS%TRUNCATION .LT. OTHER%TRUNCATION ) ! ENDIF ! Trace end of procedure (on success) @@ -1466,6 +1732,7 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SET_ENUM_INT( THIS, ID, VALUE, HOOKS ) R USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TIME_E USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_STEP_E USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_PACKING_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TRUNCATION_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1551,6 +1818,8 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_SET_ENUM_INT( THIS, ID, VALUE, HOOKS ) R THIS%STEP = VALUE CASE (MSGINTFLD_PACKING_E) THIS%PACKING = VALUE + CASE (MSGINTFLD_TRUNCATION_E) + THIS%TRUNCATION = VALUE CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_INVALID_FIELD_ID ) END SELECT @@ -2148,6 +2417,7 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_GET_ENUM_INT( THIS, ID, VALUE, HOOKS ) R USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TIME_E USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_STEP_E USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_PACKING_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TRUNCATION_E USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E ! Symbols imported by the preprocessor for debugging purposes @@ -2239,6 +2509,8 @@ PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_GET_ENUM_INT( THIS, ID, VALUE, HOOKS ) R VALUE = THIS%STEP CASE (MSGINTFLD_PACKING_E) VALUE = THIS%PACKING + CASE (MSGINTFLD_TRUNCATION_E) + VALUE = THIS%TRUNCATION CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_INVALID_FIELD_ID ) END SELECT @@ -3511,6 +3783,320 @@ END FUNCTION FORTRAN_MESSAGE_READ_FROM_YAML #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'FORTRAN_MESSAGE_TO_YAML' +PP_THREAD_SAFE FUNCTION FORTRAN_MESSAGE_TO_YAML( THIS, UNIT, OFFSET, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + USE :: ENUMERATORS_MOD, ONLY: IPARAMTYPE2CPARAMTYPE + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + USE :: DATETIME_UTILS_MOD, ONLY: HHMMSS2STRING + USE :: DATETIME_UTILS_MOD, ONLY: YYYYMMDD2STRING + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(FORTRAN_MESSAGE_T), INTENT(IN) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local parameters + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STAT + LOGICAL :: UNIT_OPENED + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNIT_NOT_OPENED=0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ISTREAM2CSTREAM=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ITYPE2CTYPE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ICLASS2CCLASS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPACKING2CPACKING=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IPARAMTYPE2CPARAMTYPE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ILEVTYPE2CLEVTYPE=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IREPRES2CREPRES=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_DATE_TO_STRING=9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TIME_TO_STRING=10_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Erro handling + INQUIRE(UNIT=UNIT, OPENED=UNIT_OPENED) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.UNIT_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET)//'message:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + + ! Print Stream + IF ( THIS%STREAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ISTREAM2CSTREAM) ISTREAM2CSTREAM( THIS%STREAM, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'stream: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Type + IF ( THIS%TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ITYPE2CTYPE) ITYPE2CTYPE( THIS%TYPE, CTMP, HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'type: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Class + IF ( THIS%CLASS .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ICLASS2CCLASS) ICLASS2CCLASS( THIS%CLASS, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'class: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print Expver + IF ( THIS%EXPVER .NE. '****' ) THEN + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'expver: "'//TRIM(ADJUSTL(THIS%EXPVER))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PACKING + IF ( THIS%PACKING .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPACKING2CPACKING) IPACKING2CPACKING( THIS%PACKING, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'packing: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print NUMBER + IF ( THIS%NUMBER .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%NUMBER + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'number: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print IDENT + IF ( THIS%IDENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%IDENT + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'ident: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print INSTRUMENT + IF ( THIS%INSTRUMENT .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%INSTRUMENT + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'instrument: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print CHANNEL + IF ( THIS%CHANNEL .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHANNEL + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'channel: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PARAM_TYPE + IF ( THIS%PARAM_TYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_IPARAMTYPE2CPARAMTYPE) IPARAMTYPE2CPARAMTYPE( THIS%PARAM_TYPE, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'paramtype: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print CHEM + IF ( THIS%CHEM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%CHEM + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'chem: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print PARAM + IF ( THIS%PARAM .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%PARAM + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'param: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print LEVTYPE + IF ( THIS%LEVTYPE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) ILEVTYPE2CLEVTYPE( THIS%LEVTYPE, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'levtype: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print LEVELIST + IF ( THIS%LEVELIST .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%LEVELIST + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'levelist: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print DIRECTION + IF ( THIS%DIRECTION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%DIRECTION + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'direction: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print FREQUENCY + IF ( THIS%FREQUENCY .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%FREQUENCY + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'frequency: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print DATE + IF ( THIS%DATE .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_DATE_TO_STRING) YYYYMMDD2STRING( THIS%DATE, CTMP(1:10), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'date: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TIME + IF ( THIS%TIME .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_TIME_TO_STRING) HHMMSS2STRING( THIS%TIME, CTMP(1:8), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'time: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print STEP + IF ( THIS%STEP .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%STEP + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'step: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TIMEPROC + IF ( THIS%TIMEPROC .NE. '********' ) THEN + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'timeproc: "'//TRIM(ADJUSTL(THIS%TIMEPROC))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print REPRES + IF ( THIS%REPRES .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) IREPRES2CREPRES( THIS%REPRES, CTMP(1:16), HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'repres: "'//TRIM(ADJUSTL(CTMP))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print GRID + IF ( THIS%GRID .NE. '********' ) THEN + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'grid: "'//TRIM(ADJUSTL(THIS%GRID))//'"' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print TRUNCATION + IF ( THIS%TRUNCATION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%TRUNCATION + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'truncation: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNIT_NOT_OPENED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unit not opened' ) + CASE (ERRFLAG_DATE_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'YYYYMMDD2STRING failed' ) + CASE (ERRFLAG_TIME_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'HHMMSS2STRING failed' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION FORTRAN_MESSAGE_TO_YAML +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + END MODULE FORTRAN_MESSAGE_MOD #undef PP_SECTION_NAME #undef PP_SECTION_TYPE diff --git a/src/multiom/data-structures/mars/record_base_mod.F90 b/src/multiom/data-structures/mars/record_base_mod.F90 deleted file mode 100644 index 8bbc0839c..000000000 --- a/src/multiom/data-structures/mars/record_base_mod.F90 +++ /dev/null @@ -1,125 +0,0 @@ -! Include preprocessor utils -#include "output_manager_preprocessor_utils.h" -#include "output_manager_preprocessor_trace_utils.h" -#include "output_manager_preprocessor_logging_utils.h" -#include "output_manager_preprocessor_errhdl_utils.h" - - -#define PP_FILE_NAME 'record_base_mod.F90' -#define PP_SECTION_TYPE 'MODULE' -#define PP_SECTION_NAME 'RECORD_BASE_MOD' -MODULE RECORD_BASE_MOD - - !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - -IMPLICIT NONE - -!> Default visibility of the module members -PRIVATE - -TYPE :: RECORD_COLLECTION_T - CHARACTER(LEN=128) :: NAME_= REPEAT( ' ', 16 ) - CLASS(RECORD_BASE_A), ALLOCATABLE :: RECORD_ => NULL() -END TYPE - - -TYPE, ABSTRACT :: RECORD_BASE_A - - !> Symbols imported from other modules within the project. - LOGICAL :: INITIALIZED_ = .FALSE. - - !> Value - -CONTAINS - - PROCEDURE(RECORD_INIT_IF), DEFERRED, PASS, PUBLIC :: INIT - - PROCEDURE(RECORD_HAS_IF), DEFERRED, PASS, PUBLIC :: HAS - PROCEDURE(RECORD_CHECK_IF), DEFERRED, PASS, PUBLIC :: CHECK - PROCEDURE(RECORD_RESET_IF), DEFERRED, PASS, PUBLIC :: RESET - - PROCEDURE(RECORD_SET_STRING_IF), DEFERRED, PASS, PUBLIC :: SET_STRING - PROCEDURE(RECORD_SET_BOOL_IF), DEFERRED, PASS, PUBLIC :: SET_BOOL - PROCEDURE(RECORD_SET_INT8_IF), DEFERRED, PASS, PUBLIC :: SET_INT8 - PROCEDURE(RECORD_SET_INT16_IF), DEFERRED, PASS, PUBLIC :: SET_INT16 - PROCEDURE(RECORD_SET_INT32_IF), DEFERRED, PASS, PUBLIC :: SET_INT32 - PROCEDURE(RECORD_SET_INT64_IF), DEFERRED, PASS, PUBLIC :: SET_INT64 - PROCEDURE(RECORD_SET_REAL32_IF), DEFERRED, PASS, PUBLIC :: SET_REAL32 - PROCEDURE(RECORD_SET_REAL64_IF), DEFERRED, PASS, PUBLIC :: SET_REAL64 - - PROCEDURE(RECORD_GET_STRING_IF), DEFERRED, PASS, PUBLIC :: GET_STRING - PROCEDURE(RECORD_GET_BOOL_IF), DEFERRED, PASS, PUBLIC :: GET_BOOL - PROCEDURE(RECORD_GET_INT8_IF), DEFERRED, PASS, PUBLIC :: GET_INT8 - PROCEDURE(RECORD_GET_INT16_IF), DEFERRED, PASS, PUBLIC :: GET_INT16 - PROCEDURE(RECORD_GET_INT32_IF), DEFERRED, PASS, PUBLIC :: GET_INT32 - PROCEDURE(RECORD_GET_INT64_IF), DEFERRED, PASS, PUBLIC :: GET_INT64 - PROCEDURE(RECORD_GET_REAL32_IF), DEFERRED, PASS, PUBLIC :: GET_REAL32 - PROCEDURE(RECORD_GET_REAL64_IF), DEFERRED, PASS, PUBLIC :: GET_REAL64 - - PROCEDURE(RECORD_TO_JSON_IF), DEFERRED, PASS, PUBLIC :: TO_JSON - PROCEDURE(RECORD_TO_YAML_IF), DEFERRED, PASS, PUBLIC :: TO_YAML - - PROCEDURE(RECORD_FROM_JSON_IF), DEFERRED, PASS, PUBLIC :: FROM_JSON - PROCEDURE(RECORD_FROM_YAML_IF), DEFERRED, PASS, PUBLIC :: FROM_YAML - - PROCEDURE(RECORD_FREE_IF), DEFERRED, PASS, PUBLIC :: FREE - -END TYPE - - -ABSTRACT INTERFACE - -PP_THREAD_SAFE FUNCTION RECORD_INIT_IF( THIS, HOOKS ) RESULT(RET) - - !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - - ! Imported abstract class - IMPORT :: RECORD_BASE_A - -IMPLICIT NONE - - !> Dummy arguments - CLASS(GRIB_SECTION_BASE_A), INTENT(INOUT) :: THIS - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS - - !> Function result - INTEGER(KIND=JPIB_K) :: RET - -END FUNCTION RECORD_INIT_IF - - - -PP_THREAD_SAFE FUNCTION RECORD_FREE_IF( THIS, HOOKS ) RESULT(RET) - - !> Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - - ! Imported abstract class - IMPORT :: RECORD_BASE_A - -IMPLICIT NONE - - !> Dummy arguments - CLASS(GRIB_SECTION_BASE_A), INTENT(INOUT) :: THIS - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS - - !> Function result - INTEGER(KIND=JPIB_K) :: RET - -END FUNCTION RECORD_FREE_IF - - - -END INTERFACE - -!> Whitelist of public symbols (Interfaces) -PUBLIC :: RECORD_BASE_A - -END MODULE RECORD_BASE_MOD -#undef PP_SECTION_NAME -#undef PP_SECTION_TYPE -#undef PP_FILE_NAME diff --git a/src/multiom/data-structures/mars/records/class_record_mod.F90 b/src/multiom/data-structures/mars/records/class_record_mod.F90 new file mode 100644 index 000000000..fb0049d5d --- /dev/null +++ b/src/multiom/data-structures/mars/records/class_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'class_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'CLASS_RECORD_MOD' +MODULE CLASS_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a class value +TYPE, EXTENDS(RECORD_BASE_A) :: CLASS_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: CLASS_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_INIT' +PP_THREAD_SAFE FUNCTION CLASS_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_HAS' +PP_THREAD_SAFE FUNCTION CLASS_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_IS_SCALAR' +PP_THREAD_SAFE FUNCTION CLASS_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_IS_RANGE' +PP_THREAD_SAFE FUNCTION CLASS_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_IS_ARRAY' +PP_THREAD_SAFE FUNCTION CLASS_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_STRING' +PP_THREAD_SAFE FUNCTION CLASS_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CCLASS2ICLASS + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CCLASS2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "stream"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "class" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_BOOL' +PP_THREAD_SAFE FUNCTION CLASS_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_INT64' +PP_THREAD_SAFE FUNCTION CLASS_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ICLASS2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "class"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION CLASS_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION CLASS_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_REAL64' +PP_THREAD_SAFE FUNCTION CLASS_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION CLASS_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_STRING' +PP_THREAD_SAFE FUNCTION CLASS_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ICLASS2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "class" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_BOOL' +PP_THREAD_SAFE FUNCTION CLASS_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_INT64' +PP_THREAD_SAFE FUNCTION CLASS_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION CLASS_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION CLASS_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_REAL64' +PP_THREAD_SAFE FUNCTION CLASS_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION CLASS_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"class" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_TO_STRING' +PP_THREAD_SAFE FUNCTION CLASS_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ICLASS2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "class" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "class" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION CLASS_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (CLASS_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION CLASS_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (CLASS_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_COPY_FROM' +PP_THREAD_SAFE FUNCTION CLASS_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_CLASS=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => CLASS_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_CLASS ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_CLASS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong class for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION CLASS_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CLASS_FREE' +PP_THREAD_SAFE FUNCTION CLASS_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CLASS_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION CLASS_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE CLASS_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/levtype_record_mod.F90 b/src/multiom/data-structures/mars/records/levtype_record_mod.F90 new file mode 100644 index 000000000..7b807718a --- /dev/null +++ b/src/multiom/data-structures/mars/records/levtype_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'levtype_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'LEVTYPE_RECORD_MOD' +MODULE LEVTYPE_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a levtype value +TYPE, EXTENDS(RECORD_BASE_A) :: LEVTYPE_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: LEVTYPE_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_INIT' +PP_THREAD_SAFE FUNCTION LEVTYPE_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_HAS' +PP_THREAD_SAFE FUNCTION LEVTYPE_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_IS_SCALAR' +PP_THREAD_SAFE FUNCTION LEVTYPE_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_IS_RANGE' +PP_THREAD_SAFE FUNCTION LEVTYPE_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_IS_ARRAY' +PP_THREAD_SAFE FUNCTION LEVTYPE_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_STRING' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CLEVTYPE2ILEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CLEVTYPE2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "levtype"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "levtype" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_BOOL' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_INT64' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ILEVTYPE2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "levtype"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_REAL64' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION LEVTYPE_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_STRING' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ILEVTYPE2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "levtype" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_BOOL' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_INT64' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_REAL64' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION LEVTYPE_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"levtype" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_TO_STRING' +PP_THREAD_SAFE FUNCTION LEVTYPE_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ILEVTYPE2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "levtype" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "levtype" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION LEVTYPE_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (LEVTYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION LEVTYPE_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (LEVTYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_COPY_FROM' +PP_THREAD_SAFE FUNCTION LEVTYPE_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_LEVTYPE=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => LEVTYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_LEVTYPE ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_LEVTYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong levtype for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVTYPE_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVTYPE_FREE' +PP_THREAD_SAFE FUNCTION LEVTYPE_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVTYPE_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION LEVTYPE_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE LEVTYPE_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/origin_record_mod.F90 b/src/multiom/data-structures/mars/records/origin_record_mod.F90 new file mode 100644 index 000000000..e5d01e178 --- /dev/null +++ b/src/multiom/data-structures/mars/records/origin_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'origin_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'ORIGIN_RECORD_MOD' +MODULE ORIGIN_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a origin value +TYPE, EXTENDS(RECORD_BASE_A) :: ORIGIN_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: ORIGIN_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_INIT' +PP_THREAD_SAFE FUNCTION ORIGIN_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_HAS' +PP_THREAD_SAFE FUNCTION ORIGIN_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_IS_SCALAR' +PP_THREAD_SAFE FUNCTION ORIGIN_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_IS_RANGE' +PP_THREAD_SAFE FUNCTION ORIGIN_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_IS_ARRAY' +PP_THREAD_SAFE FUNCTION ORIGIN_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_STRING' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CORIGIN2IORIGIN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CORIGIN2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "origin"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "origin" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_BOOL' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_INT64' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: IORIGIN2CORIGIN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IORIGIN2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "origin"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_REAL64' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION ORIGIN_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_STRING' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IORIGIN2CORIGIN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IORIGIN2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "origin" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_BOOL' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_INT64' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_REAL64' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION ORIGIN_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"origin" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_TO_STRING' +PP_THREAD_SAFE FUNCTION ORIGIN_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IORIGIN2CORIGIN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IORIGIN2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "origin" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "origin" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION ORIGIN_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (ORIGIN_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION ORIGIN_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (ORIGIN_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_COPY_FROM' +PP_THREAD_SAFE FUNCTION ORIGIN_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_ORIGIN=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => ORIGIN_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_ORIGIN ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_ORIGIN) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong origin for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ORIGIN_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ORIGIN_FREE' +PP_THREAD_SAFE FUNCTION ORIGIN_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ORIGIN_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION ORIGIN_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE ORIGIN_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/packing_record_mod.F90 b/src/multiom/data-structures/mars/records/packing_record_mod.F90 new file mode 100644 index 000000000..df4d13216 --- /dev/null +++ b/src/multiom/data-structures/mars/records/packing_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'packing_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'PACKING_RECORD_MOD' +MODULE PACKING_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a packing value +TYPE, EXTENDS(RECORD_BASE_A) :: PACKING_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: PACKING_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_INIT' +PP_THREAD_SAFE FUNCTION PACKING_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_HAS' +PP_THREAD_SAFE FUNCTION PACKING_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_IS_SCALAR' +PP_THREAD_SAFE FUNCTION PACKING_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_IS_RANGE' +PP_THREAD_SAFE FUNCTION PACKING_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_IS_ARRAY' +PP_THREAD_SAFE FUNCTION PACKING_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_STRING' +PP_THREAD_SAFE FUNCTION PACKING_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CPACKING2IPACKING + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CPACKING2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "packing"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "packing" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_BOOL' +PP_THREAD_SAFE FUNCTION PACKING_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_INT64' +PP_THREAD_SAFE FUNCTION PACKING_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IPACKING2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "packing"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION PACKING_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION PACKING_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_REAL64' +PP_THREAD_SAFE FUNCTION PACKING_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION PACKING_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_STRING' +PP_THREAD_SAFE FUNCTION PACKING_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IPACKING2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "packing" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_BOOL' +PP_THREAD_SAFE FUNCTION PACKING_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_INT64' +PP_THREAD_SAFE FUNCTION PACKING_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION PACKING_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION PACKING_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_REAL64' +PP_THREAD_SAFE FUNCTION PACKING_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION PACKING_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"packing" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_TO_STRING' +PP_THREAD_SAFE FUNCTION PACKING_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IPACKING2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "packing" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "packing" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION PACKING_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (PACKING_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION PACKING_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (PACKING_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_COPY_FROM' +PP_THREAD_SAFE FUNCTION PACKING_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_PACKING=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => PACKING_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_PACKING ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_PACKING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong packing for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PACKING_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PACKING_FREE' +PP_THREAD_SAFE FUNCTION PACKING_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PACKING_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION PACKING_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE PACKING_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/record_base_mod.F90 b/src/multiom/data-structures/mars/records/record_base_mod.F90 new file mode 100644 index 000000000..c9dc72185 --- /dev/null +++ b/src/multiom/data-structures/mars/records/record_base_mod.F90 @@ -0,0 +1,677 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'record_base_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'RECORD_BASE_MOD' +MODULE RECORD_BASE_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + +IMPLICIT NONE + +!> Default visibility of the module members +PRIVATE + +TYPE :: RECORD_COLLECTION_T + CHARACTER(LEN=128) :: NAME_= REPEAT( ' ', 16 ) + CLASS(RECORD_BASE_A), ALLOCATABLE :: RECORD_ => NULL() +END TYPE + + +TYPE, ABSTRACT :: RECORD_BASE_A + + !> Symbols imported from other modules within the project. + LOGICAL :: INITIALIZED_ = .FALSE. + + !> Value + +CONTAINS + + !> @brief Initializes the record + PROCEDURE(RECORD_INIT_IF), DEFERRED, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE(RECORD_HAS_IF), DEFERRED, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE(RECORD_IS_RANGE_IF), DEFERRED, PASS, PUBLIC :: IS_SCALAR + PROCEDURE(RECORD_IS_RANGE_IF), DEFERRED, PASS, PUBLIC :: IS_RANGE + PROCEDURE(RECORD_IS_RANGE_IF), DEFERRED, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE(RECORD_RESET_IF), DEFERRED, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE(RECORD_SET_STRING_IF), DEFERRED, PASS, PUBLIC :: SET_STRING + PROCEDURE(RECORD_SET_BOOL_IF), DEFERRED, PASS, PUBLIC :: SET_BOOL + PROCEDURE(RECORD_SET_INT64_IF), DEFERRED, PASS, PUBLIC :: SET_INT64 + PROCEDURE(RECORD_SET_REAL32_IF), DEFERRED, PASS, PUBLIC :: SET_REAL64 + PROCEDURE(RECORD_SET_INT64_RANGE_IF), DEFERRED, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE(RECORD_SET_INT64_ARRAY_IF), DEFERRED, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE(RECORD_SET_REAL32_ARRAY_IF), DEFERRED, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE(RECORD_GET_STRING_IF), DEFERRED, PASS, PUBLIC :: GET_STRING + PROCEDURE(RECORD_GET_BOOL_IF), DEFERRED, PASS, PUBLIC :: GET_BOOL + PROCEDURE(RECORD_GET_INT64_IF), DEFERRED, PASS, PUBLIC :: GET_INT64 + PROCEDURE(RECORD_GET_REAL32_IF), DEFERRED, PASS, PUBLIC :: GET_REAL64 + PROCEDURE(RECORD_GET_INT64_RANGE_IF), DEFERRED, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE(RECORD_GET_INT64_ARRAY_IF), DEFERRED, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE(RECORD_GET_REAL64_ARRAY_IF), DEFERRED, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE(RECORD_TO_STRING_IF), DEFERRED, PASS, PUBLIC :: TO_STRING + + !> @brief Compare two records for equality + PROCEDURE(RECORD_IS_EQUAL_TO_IF), DEFERRED, PASS, PUBLIC :: IS_EQUAL_TO + + !> @brief Compare two records for ordering + PROCEDURE(RECORD_IS_LOWER_THAN_IF), DEFERRED, PASS, PUBLIC :: IS_LOWER_THAN + + !> @brief Copy state to other + PROCEDURE(RECORD_COPY_FROM_IF), DEFERRED, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE(RECORD_FREE_IF), DEFERRED, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + + +ABSTRACT INTERFACE + +PP_THREAD_SAFE FUNCTION RECORD_INIT_IF( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_INIT_IF + +PP_THREAD_SAFE FUNCTION RECORD_HAS_IF( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_HAS_IF + +PP_THREAD_SAFE FUNCTION RECORD_IS_SCALAR_IF( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_IS_SCALAR_IF + +PP_THREAD_SAFE FUNCTION RECORD_IS_RANGE_IF( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_IS_RANGE_IF + +PP_THREAD_SAFE FUNCTION RECORD_IS_ARRAY_IF( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_IS_ARRAY_IF + + +PP_THREAD_SAFE FUNCTION RECORD_RESET_IF( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUES_IS_OK + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_RESET_IF + + + + +PP_THREAD_SAFE FUNCTION RECORD_SET_STRING_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_STRING_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_BOOL_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_BOOL_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_INT64_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_INT64_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_INT64_RANGE_IF( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE1 + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_INT64_RANGE_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_INT64_ARRAY_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_INT64_ARRAY_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_REAL64_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_REAL64_IF + + +PP_THREAD_SAFE FUNCTION RECORD_SET_REAL64_ARRAY_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_SET_REAL64_ARRAY_IF + + + +PP_THREAD_SAFE FUNCTION RECORD_TO_STRING_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_TO_STRING_IF + +PP_THREAD_SAFE FUNCTION RECORD_GET_STRING_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_STRING_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_BOOL_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_BOOL_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_INT64_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_INT64_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_INT64_RANGE_IF( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE1 + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_INT64_RANGE_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_INT64_ARRAY_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_INT64_ARRAY_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_REAL64_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_REAL64_IF + + +PP_THREAD_SAFE FUNCTION RECORD_GET_REAL64_ARRAY_IF( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_GET_REAL64_ARRAY_IF + + + + +PP_THREAD_SAFE FUNCTION RECORD_IS_EQUAL_TO_IF( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_IS_EQUAL_TO_IF + + + + +PP_THREAD_SAFE FUNCTION RECORD_IS_LOWER_THAN_IF( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_IS_LOWER_THAN_IF + + + + +PP_THREAD_SAFE FUNCTION RECORD_COPY_FROM_IF( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_COPY_FROM_IF + + + +PP_THREAD_SAFE FUNCTION RECORD_FREE_IF( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Imported abstract class + IMPORT :: RECORD_BASE_A + +IMPLICIT NONE + + !> Dummy arguments + CLASS(RECORD_BASE_A), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + +END FUNCTION RECORD_FREE_IF + + + +END INTERFACE + +!> Whitelist of public symbols (Interfaces) +PUBLIC :: RECORD_BASE_A + +END MODULE RECORD_BASE_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME diff --git a/src/multiom/data-structures/mars/records/repres_record_mod.F90 b/src/multiom/data-structures/mars/records/repres_record_mod.F90 new file mode 100644 index 000000000..b0e33c226 --- /dev/null +++ b/src/multiom/data-structures/mars/records/repres_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'repres_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'REPRES_RECORD_MOD' +MODULE REPRES_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a repres value +TYPE, EXTENDS(RECORD_BASE_A) :: REPRES_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: REPRES_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_INIT' +PP_THREAD_SAFE FUNCTION REPRES_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_HAS' +PP_THREAD_SAFE FUNCTION REPRES_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_IS_SCALAR' +PP_THREAD_SAFE FUNCTION REPRES_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_IS_RANGE' +PP_THREAD_SAFE FUNCTION REPRES_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_IS_ARRAY' +PP_THREAD_SAFE FUNCTION REPRES_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_STRING' +PP_THREAD_SAFE FUNCTION REPRES_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CREPRES2IREPRES + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CREPRES2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "repres"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "repres" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_BOOL' +PP_THREAD_SAFE FUNCTION REPRES_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_INT64' +PP_THREAD_SAFE FUNCTION REPRES_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IREPRES2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "repres"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION REPRES_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION REPRES_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_REAL64' +PP_THREAD_SAFE FUNCTION REPRES_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION REPRES_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_STRING' +PP_THREAD_SAFE FUNCTION REPRES_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IREPRES2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "repres" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_BOOL' +PP_THREAD_SAFE FUNCTION REPRES_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_INT64' +PP_THREAD_SAFE FUNCTION REPRES_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION REPRES_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION REPRES_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_REAL64' +PP_THREAD_SAFE FUNCTION REPRES_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION REPRES_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"repres" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_TO_STRING' +PP_THREAD_SAFE FUNCTION REPRES_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) IREPRES2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "repres" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "repres" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION REPRES_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (REPRES_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION REPRES_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (REPRES_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_COPY_FROM' +PP_THREAD_SAFE FUNCTION REPRES_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_REPRES=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => REPRES_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_REPRES ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_REPRES) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong repres for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_FREE' +PP_THREAD_SAFE FUNCTION REPRES_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(REPRES_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION REPRES_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE REPRES_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/stream_record_mod.F90 b/src/multiom/data-structures/mars/records/stream_record_mod.F90 new file mode 100644 index 000000000..3922d9d57 --- /dev/null +++ b/src/multiom/data-structures/mars/records/stream_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'stream_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'STREAM_RECORD_MOD' +MODULE STREAM_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a stream value +TYPE, EXTENDS(RECORD_BASE_A) :: STREAM_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: STREAM_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_INIT' +PP_THREAD_SAFE FUNCTION STREAM_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_HAS' +PP_THREAD_SAFE FUNCTION STREAM_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_IS_SCALAR' +PP_THREAD_SAFE FUNCTION STREAM_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_IS_RANGE' +PP_THREAD_SAFE FUNCTION STREAM_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_IS_ARRAY' +PP_THREAD_SAFE FUNCTION STREAM_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_STRING' +PP_THREAD_SAFE FUNCTION STREAM_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CSTREAM2ISTREAM + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CSTREAM2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "stream"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "stream" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_BOOL' +PP_THREAD_SAFE FUNCTION STREAM_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_INT64' +PP_THREAD_SAFE FUNCTION STREAM_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ISTREAM2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "stream"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION STREAM_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION STREAM_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_REAL64' +PP_THREAD_SAFE FUNCTION STREAM_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION STREAM_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_STRING' +PP_THREAD_SAFE FUNCTION STREAM_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ISTREAM2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "stream" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_BOOL' +PP_THREAD_SAFE FUNCTION STREAM_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_INT64' +PP_THREAD_SAFE FUNCTION STREAM_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION STREAM_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION STREAM_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_REAL64' +PP_THREAD_SAFE FUNCTION STREAM_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION STREAM_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"stream" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_TO_STRING' +PP_THREAD_SAFE FUNCTION STREAM_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ISTREAM2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "stream" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "stream" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION STREAM_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (STREAM_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION STREAM_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (STREAM_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_COPY_FROM' +PP_THREAD_SAFE FUNCTION STREAM_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_STREAM=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => STREAM_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_STREAM ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_STREAM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong stream for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION STREAM_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STREAM_FREE' +PP_THREAD_SAFE FUNCTION STREAM_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(STREAM_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION STREAM_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE STREAM_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/mars/records/type_record_mod.F90 b/src/multiom/data-structures/mars/records/type_record_mod.F90 new file mode 100644 index 000000000..f634ac512 --- /dev/null +++ b/src/multiom/data-structures/mars/records/type_record_mod.F90 @@ -0,0 +1,2316 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'type_record_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'TYPE_RECORD_MOD' +MODULE TYPE_RECORD_MOD + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: RECORD_BASE_MOD, ONLY: RECORD_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> Maximum lenght of the calss value as string +INTEGER(KIND=JPIB_K), PARAMETER :: CVALUE_LEN=2_JPIB_K + +!> Record used to wrap a type value +TYPE, EXTENDS(RECORD_BASE_A) :: TYPE_RECORD_T + + !> Default visibility of the type + PRIVATE + + !> Value + INTEGER(KIND=JPIB_K) :: VALUE_= UNDEF_PARAM_E + +CONTAINS + + !> @brief Initializes the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: INIT + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: HAS + + !> @brief Checks if the record has been initialized + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_SCALAR + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_ARRAY + + !> @brief Reset to value to an unitialized value + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: RESET + + !> @brief Set the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: SET_REAL64_ARRAY + + !> @brief Get the value of the record + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_BOOL + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64 + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_RANGE + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_INT64_ARRAY + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: GET_REAL64_ARRAY + + !> @brief Convert the record to a string to be printed + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: TO_STRING + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_LOWER_THAN + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: IS_EQUAL_TO + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: COPY_FROM + + !> @brief Free the record (reset all internal fields) + PROCEDURE, NON_OVERRIDABLE, PASS, PUBLIC :: FREE + + ! Generic interface for setting values + GENERIC, PUBLIC :: SET => SET_STRING + GENERIC, PUBLIC :: SET => SET_BOOL + GENERIC, PUBLIC :: SET => SET_INT64 + GENERIC, PUBLIC :: SET => SET_INT64_ARRAY + GENERIC, PUBLIC :: SET => SET_INT_64_RANGE + GENERIC, PUBLIC :: SET => SET_REAL64 + GENERIC, PUBLIC :: SET => SET_REAL64_ARRAY + + + ! Generic interface for setting values + GENERIC, PUBLIC :: GET => GET_STRING + GENERIC, PUBLIC :: GET => GET_BOOL + GENERIC, PUBLIC :: GET => GET_INT64 + GENERIC, PUBLIC :: GET => GET_INT64_ARRAY + GENERIC, PUBLIC :: GET => GET_INT_64_RANGE + GENERIC, PUBLIC :: GET => GET_REAL64 + GENERIC, PUBLIC :: GET => GET_REAL64_ARRAY + +END TYPE + +! Whitelist of public symbols +PUBLIC :: TYPE_RECORD_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_INIT' +PP_THREAD_SAFE FUNCTION TYPE_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_HAS' +PP_THREAD_SAFE FUNCTION TYPE_HAS( THIS, HAS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: HAS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + HAS = THIS%INITIALIZED_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_HAS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_IS_SCALAR' +PP_THREAD_SAFE FUNCTION TYPE_IS_SCALAR( THIS, IS_SCALAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_SCALAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_SCALAR = .TRUE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_IS_SCALAR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_IS_RANGE' +PP_THREAD_SAFE FUNCTION TYPE_IS_RANGE( THIS, IS_RANGE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_RANGE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_RANGE = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_IS_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_IS_ARRAY' +PP_THREAD_SAFE FUNCTION TYPE_IS_ARRAY( THIS, IS_ARRAY, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: IS_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + IS_ARRAY = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_IS_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_STRING' +PP_THREAD_SAFE FUNCTION TYPE_SET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: CTYPE2ITYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CTYPE2ICLASS(VALUE, THIS%VALUE_, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid length for "type"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "type" to enum' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_BOOL' +PP_THREAD_SAFE FUNCTION TYPE_SET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(L)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to bool' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_INT64' +PP_THREAD_SAFE FUNCTION TYPE_SET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=CVALUE_LEN) :: CVALUE + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Try to convert to string just to check that the value is valid + CVALUE = REPEAT(' ', CVALUE_LEN) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ITYPE2CCLASS(VALUE, CVALUE, HOOKS) + + ! Initialize the values of the record + THIS%VALUE_ = VALUE + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + CTMP = REPEAT(' ', 32) + WRITE(CTMP, '(I32)', IOSTAT=WRITE_STATUS) VALUE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Invalid enum for "type"' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(CTMP) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION TYPE_SET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(IN) :: VALUE1 + LOGICAL, INTENT(IN) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION TYPE_SET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_REAL64' +PP_THREAD_SAFE FUNCTION TYPE_SET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_SET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION TYPE_SET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_SET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_STRING' +PP_THREAD_SAFE FUNCTION TYPE_GET_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ITYPE2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "type" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_BOOL' +PP_THREAD_SAFE FUNCTION TYPE_GET_BOOL( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to bool' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_BOOL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_INT64' +PP_THREAD_SAFE FUNCTION TYPE_GET_INT64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + + ! Initialize the values of the record + VALUE = HIS%VALUE_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not defined' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_INT64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_INT64_RANGE' +PP_THREAD_SAFE FUNCTION TYPE_GET_INT64_RANGE( THIS, VALUE1, VALUE2, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + LOGICAL, INTENT(OUT) :: VALUE1 + LOGICAL, INTENT(OUT) :: VALUE2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to int64-range' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Input value: ' // TRIM(VALUE) ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_INT64_RANGE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_INT64_ARRAY' +PP_THREAD_SAFE FUNCTION TYPE_GET_INT64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to int64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_INT64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_REAL64' +PP_THREAD_SAFE FUNCTION TYPE_GET_REAL64( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to real64' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_REAL64 +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_GET_REAL64_ARRAY' +PP_THREAD_SAFE FUNCTION TYPE_GET_REAL64_ARRAY( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_APPLICABLE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_APPLICABLE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_APPLICABLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( '"type" cannot be converted to real64-array' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_GET_REAL64_ARRAY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_TO_STRING' +PP_THREAD_SAFE FUNCTION TYPE_TO_STRING( THIS, VALUE, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(OUT) :: VALUE + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Errorf flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_WRONG_LENGTH=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_GET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.THIS%INITIALIZED_, ERRFLAG_VALUE_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( THIS%VALUE_.EQ.UNDEF_PARAM_E, ERRFLAG_VALUE_UNDEFINED ) + PP_DEBUG_CRITICAL_COND_THROW( LEN(VALUE).LT.CVALUE_LEN, ERRFLAG_VALUE_WRONG_LENGTH ) + + ! Initialize the values of the record + VALUE = REPEAT(' ', LEN(VALUE)) + P_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) ITYPE2CCLASS(THIS%VALUE_, VALUE, HOOKS) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_GET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_VALUE_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not initialized' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" is not defined' ) + CASE (ERRFLAG_VALUE_WRONG_LENGTH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Value for "type" has wrong length' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert "type" to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_TO_STRING +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_IS_EQUAL_TO' +PP_THREAD_SAFE FUNCTION TYPE_IS_EQUAL_TO( THIS, OTHER, IS_EQUAL_TO, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_EQUAL_TO + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(O => OTHER) + CLASS IS (TYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .EQ. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + IS_EQUAL_TO = THIS%VALUE_ == OTHER%VALUE_ + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_IS_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_IS_LOWER_THAN' +PP_THREAD_SAFE FUNCTION TYPE_IS_LOWER_THAN( THIS, OTHER, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(0 => OTHER) + CLASS IS (TYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( THIS%INITIALIZED_ .AND HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + IS_EQUAL_TO = THIS%VALUE_ .LT. OTHER_VALUE + ELSEIF ( THIS%INITIALIZED_ .AND .NOT.HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSEIF ( .NOT.THIS%INITIALIZED_ .AND. HAS ) THEN + IS_EQUAL_TO = .FALSE. + ELSE + IS_EQUAL_TO = .TRUE. + END IF + CLASS DEFAULT + IS_EQUAL_TO = .FALSE. + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_IS_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_COPY_FROM' +PP_THREAD_SAFE FUNCTION TYPE_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + CLASS(RECORD_BASE_A), POINTER, INTENT(IN) :: OTHER + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: OTHER_VALUE + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_CHECK=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OTHER_UNABLE_TO_GET=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_OTHER_TYPE=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + SELECT TYPE(OTHER) + CLASS IS (O => TYPE_RECORD_T) + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_CHECK) O%HAS( HAS, HOOKS ) + IF ( HAS ) THEN + PP_TRYCALL(ERRFLAG_OTHER_UNABLE_TO_GET) O%GET_INT64( OTHER_VALUE, HOOKS ) + THIS%INITIALIZED_ = .TRUE. + THIS%VALUE_ = OTHER_VALUE + ELSE + THIS%INITIALIZED_ = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + END IF + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_WRONG_OTHER_TYPE ) + END SELECT + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + CHARACTER(LEN=16) :: TMPSTR + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_OTHER_UNABLE_TO_CHECK) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to check if "other" has the value' ) + CASE (ERRFLAG_OTHER_UNABLE_TO_GET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to get the value of "other"' ) + CASE (ERRFLAG_WRONG_OTHER_TYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Wrong type for "other"' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TYPE_COPY_FROM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TYPE_FREE' +PP_THREAD_SAFE FUNCTION TYPE_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TYPE_RECORD_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the values of the record + THIS%INITIALIZED = .FALSE. + THIS%VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION TYPE_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE TYPE_RECORD_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/data-structures/parametrization/CMakeLists.txt b/src/multiom/data-structures/parametrization/CMakeLists.txt index 272aaef97..6e688e7b2 100644 --- a/src/multiom/data-structures/parametrization/CMakeLists.txt +++ b/src/multiom/data-structures/parametrization/CMakeLists.txt @@ -22,6 +22,8 @@ set( MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_MAIN_SOURCES ${MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_DIR}/satellite_par_mod.F90 ${MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_DIR}/level_par_mod.F90 ${MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_DIR}/wave_par_mod.F90 + ${MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_DIR}/representations_mod.F90 + ${MULTIOM_DATA_STRUCTURES_PARAMETRIZATION_DIR}/repres_map_mod.F90 ) # Collect source files in data-structures diff --git a/src/multiom/data-structures/parametrization/analysis_par_mod.F90 b/src/multiom/data-structures/parametrization/analysis_par_mod.F90 index bfd18bc0b..1ba7f0eb5 100644 --- a/src/multiom/data-structures/parametrization/analysis_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/analysis_par_mod.F90 @@ -23,6 +23,7 @@ MODULE ANALYSIS_PAR_MOD TYPE :: ANALYSIS_PAR_T INTEGER(KIND=JPIB_K) :: LENGTH_OF_TIME_WINDOW_= UNDEF_PARAM_E CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => ANALYSIS_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => ANALYSIS_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_ANALYSIS_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => WRITE_ANALYSIS_PAR_TO_YAML @@ -35,6 +36,95 @@ MODULE ANALYSIS_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ANALYSIS_PAR_INIT' +PP_THREAD_SAFE FUNCTION ANALYSIS_PAR_INIT( ANALYSIS_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ANALYSIS_PAR_T), INTENT(INOUT) :: ANALYSIS_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + ANALYSIS_PAR%LENGTH_OF_TIME_WINDOW_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ANALYSIS_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'ANALYSIS_PAR_FREE' PP_THREAD_SAFE FUNCTION ANALYSIS_PAR_FREE( ANALYSIS_PAR, HOOKS ) RESULT(RET) @@ -367,7 +457,7 @@ PP_THREAD_SAFE FUNCTION WRITE_ANALYSIS_PAR_TO_YAML( ANALYSIS_PAR, UNIT, OFFSET, IMPLICIT NONE !> Dummy arguments - CLASS(ANALYSIS_PAR_T), INTENT(INOUT) :: ANALYSIS_PAR + CLASS(ANALYSIS_PAR_T), INTENT(IN) :: ANALYSIS_PAR INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS @@ -379,6 +469,7 @@ PP_THREAD_SAFE FUNCTION WRITE_ANALYSIS_PAR_TO_YAML( ANALYSIS_PAR, UNIT, OFFSET, CHARACTER(LEN=MAX_STR_LEN) :: CTMP INTEGER(KIND=JPIB_K) :: WRITE_STAT LOGICAL :: IS_OPENED + LOGICAL, DIMENSION(1) :: CONDITIONS !> Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INVALID_OFFSET = 1_JPIB_K @@ -404,28 +495,31 @@ PP_THREAD_SAFE FUNCTION WRITE_ANALYSIS_PAR_TO_YAML( ANALYSIS_PAR, UNIT, OFFSET, ! Error handling PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) - ! Check if it is possible to write on the provided unit - INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) - ! Write to the unit - WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'analysis:' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( ANALYSIS_PAR%LENGTH_OF_TIME_WINDOW_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE + CONDITIONS(1) = ANALYSIS_PAR%LENGTH_OF_TIME_WINDOW_ .NE. UNDEF_PARAM_E + + IF ( CONDITIONS(1) ) THEN + + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'analysis:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ANALYSIS_PAR%LENGTH_OF_TIME_WINDOW_, CTMP, HOOKS ) - ENDIF - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-window: ', TRIM(ADJUSTL(CTMP)), ' # length of time window used in analysis' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-window: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! Add an empty line - WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Add an empty line + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() diff --git a/src/multiom/data-structures/parametrization/bitmap_par_mod.F90 b/src/multiom/data-structures/parametrization/bitmap_par_mod.F90 index 8015b05ab..41413333e 100644 --- a/src/multiom/data-structures/parametrization/bitmap_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/bitmap_par_mod.F90 @@ -26,6 +26,7 @@ MODULE BITMAP_PAR_MOD INTEGER(KIND=JPIB_K) :: NUMBER_OF_MISSING_VALUES_= UNDEF_PARAM_E REAL(KIND=JPRD_K) :: VALUE_OF_MISSING_VALUES_=-HUGE(0.0_JPRD_K) CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => BITMAP_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => BITMAP_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_BITMAP_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: SET_VALUE_OF_MISSING_VALUES => BITMAP_PAR_SET_VALUE_OF_MISSING_VALUES @@ -42,6 +43,96 @@ MODULE BITMAP_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'BITMAP_PAR_INIT' +PP_THREAD_SAFE FUNCTION BITMAP_PAR_INIT( BITMAP_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(BITMAP_PAR_T), INTENT(INOUT) :: BITMAP_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + BITMAP_PAR%NUMBER_OF_MISSING_VALUES_ = UNDEF_PARAM_E + BITMAP_PAR%VALUE_OF_MISSING_VALUES_ = HUGE(0.0_JPRD_K) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION BITMAP_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'BITMAP_PAR_FREE' PP_THREAD_SAFE FUNCTION BITMAP_PAR_FREE( BITMAP_PAR, HOOKS ) RESULT(RET) @@ -771,7 +862,7 @@ PP_THREAD_SAFE FUNCTION WRITE_BITMAP_PAR_TO_YAML( BITMAP_PAR, UNIT, OFFSET, HOOK IMPLICIT NONE !> Dummy arguments - CLASS(BITMAP_PAR_T), INTENT(INOUT) :: BITMAP_PAR + CLASS(BITMAP_PAR_T), INTENT(IN) :: BITMAP_PAR INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS @@ -808,43 +899,40 @@ PP_THREAD_SAFE FUNCTION WRITE_BITMAP_PAR_TO_YAML( BITMAP_PAR, UNIT, OFFSET, HOOK ! Error handling PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) - ! Check if it is possible to write on the provided unit - INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + IF ( BITMAP_PAR%NUMBER_OF_MISSING_VALUES_ .NE. UNDEF_PARAM_E ) THEN + + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) - ! Write to the unit - WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'bitmap: ' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'bitmap: ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( BITMAP_PAR%NUMBER_OF_MISSING_VALUES_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( BITMAP_PAR%NUMBER_OF_MISSING_VALUES_, CTMP, HOOKS ) - ENDIF - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'number-of-missing-values: ', & -& TRIM(ADJUSTL(CTMP)), ' # number of missing values (used only as boolean for setting "bitmapPresent")' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'number-of-missing-values: ', & +& TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( BITMAP_PAR%NUMBER_OF_MISSING_VALUES_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( BITMAP_PAR%VALUE_OF_MISSING_VALUES_, CTMP, HOOKS ) - ENDIF - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'value-of-missing-values: ', & -& TRIM(ADJUSTL(CTMP)), ' # value to be used to identify missing values in the field values' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'value-of-missing-values: ', & +& TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! Add an empty line - WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Add an empty line + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() diff --git a/src/multiom/data-structures/parametrization/data_representation_par_mod.F90 b/src/multiom/data-structures/parametrization/data_representation_par_mod.F90 index 426aef98b..a73d81041 100644 --- a/src/multiom/data-structures/parametrization/data_representation_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/data_representation_par_mod.F90 @@ -23,6 +23,7 @@ MODULE DATA_REPRESENTATION_PAR_MOD TYPE :: DATA_REPRESENTATION_PAR_T INTEGER(KIND=JPIB_K) :: BITS_PER_VALUE_= 16_JPIB_K CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => DATA_REPRESENTATION_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => DATA_REPRESENTATION_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_DATA_REPRESENTATION_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => WRITE_DATA_REPRESENTATION_PAR_TO_YAML @@ -35,6 +36,95 @@ MODULE DATA_REPRESENTATION_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'DATA_REPRESENTATION_PAR_INIT' +PP_THREAD_SAFE FUNCTION DATA_REPRESENTATION_PAR_INIT( DATA_REPRESENTATION_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(DATA_REPRESENTATION_PAR_T), INTENT(INOUT) :: DATA_REPRESENTATION_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + DATA_REPRESENTATION_PAR%BITS_PER_VALUE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION DATA_REPRESENTATION_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'DATA_REPRESENTATION_PAR_FREE' PP_THREAD_SAFE FUNCTION DATA_REPRESENTATION_PAR_FREE( DATA_REPRESENTATION_PAR, HOOKS ) RESULT(RET) @@ -373,10 +463,10 @@ PP_THREAD_SAFE FUNCTION WRITE_DATA_REPRESENTATION_PAR_TO_YAML( DATA_REPRESENTATI IMPLICIT NONE !> Dummy arguments - CLASS(DATA_REPRESENTATION_PAR_T), INTENT(INOUT) :: DATA_REPRESENTATION_PAR - INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT - INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CLASS(DATA_REPRESENTATION_PAR_T), INTENT(IN) :: DATA_REPRESENTATION_PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET @@ -423,7 +513,7 @@ PP_THREAD_SAFE FUNCTION WRITE_DATA_REPRESENTATION_PAR_TO_YAML( DATA_REPRESENTATI PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( DATA_REPRESENTATION_PAR%BITS_PER_VALUE_, CTMP, HOOKS ) ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'bits-per-value: ', TRIM(ADJUSTL(CTMP)), ' # number of bits used to save each value (default=16)' + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'bits-per-value: ', TRIM(ADJUSTL(CTMP)) PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) ! Add an empty line diff --git a/src/multiom/data-structures/parametrization/ensemble_par_mod.F90 b/src/multiom/data-structures/parametrization/ensemble_par_mod.F90 index ab849eaa5..2f3d009d5 100644 --- a/src/multiom/data-structures/parametrization/ensemble_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/ensemble_par_mod.F90 @@ -27,6 +27,7 @@ MODULE ENSEMBLE_PAR_MOD INTEGER(KIND=JPIB_K) :: TYPE_OF_ENSEMBLE_FORECAST_= UNDEF_PARAM_E INTEGER(KIND=JPIB_K) :: NUMBER_OF_FORECASTS_IN_ENSEMBLE_= UNDEF_PARAM_E CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => ENSEMBLE_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => ENSEMBLE_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_ENSEMBLE_PAR_FROM_YAML @@ -50,6 +51,98 @@ MODULE ENSEMBLE_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ENSEMBLE_PAR_INIT' +PP_THREAD_SAFE FUNCTION ENSEMBLE_PAR_INIT( ENSEMBLE_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(ENSEMBLE_PAR_T), INTENT(INOUT) :: ENSEMBLE_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + ENSEMBLE_PAR%SYSTEM_NUMBER_ = UNDEF_PARAM_E + ENSEMBLE_PAR%METHOD_NUMBER_ = UNDEF_PARAM_E + ENSEMBLE_PAR%TYPE_OF_ENSEMBLE_FORECAST_ = UNDEF_PARAM_E + ENSEMBLE_PAR%NUMBER_OF_FORECASTS_IN_ENSEMBLE_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ENSEMBLE_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'ENSEMBLE_PAR_FREE' PP_THREAD_SAFE FUNCTION ENSEMBLE_PAR_FREE( ENSEMBLE_PAR, HOOKS ) RESULT(RET) @@ -1209,6 +1302,7 @@ PP_THREAD_SAFE FUNCTION WRITE_ENSEMBLE_PAR_TO_YAML( ENSEMBLE_PAR, UNIT, OFFSET, USE :: LOG_UTILS_MOD, ONLY: TO_STRING USE :: LOG_UTILS_MOD, ONLY: MAX_STR_LEN + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1222,7 +1316,7 @@ PP_THREAD_SAFE FUNCTION WRITE_ENSEMBLE_PAR_TO_YAML( ENSEMBLE_PAR, UNIT, OFFSET, IMPLICIT NONE !> Dummy arguments - CLASS(ENSEMBLE_PAR_T), INTENT(INOUT) :: ENSEMBLE_PAR + CLASS(ENSEMBLE_PAR_T), INTENT(IN) :: ENSEMBLE_PAR INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS @@ -1234,6 +1328,7 @@ PP_THREAD_SAFE FUNCTION WRITE_ENSEMBLE_PAR_TO_YAML( ENSEMBLE_PAR, UNIT, OFFSET, CHARACTER(LEN=MAX_STR_LEN) :: CTMP INTEGER(KIND=JPIB_K) :: WRITE_STAT LOGICAL :: IS_OPENED + LOGICAL, DIMENSION(4) :: CONDITIONS !> Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INVALID_OFFSET = 1_JPIB_K @@ -1259,77 +1354,69 @@ PP_THREAD_SAFE FUNCTION WRITE_ENSEMBLE_PAR_TO_YAML( ENSEMBLE_PAR, UNIT, OFFSET, ! Error handling PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) - ! Check if it is possible to write on the provided unit - INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) - - ! Write to the unit - WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'ensemble:' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - + CONDITIONS(1) = ENSEMBLE_PAR%TYPE_OF_ENSEMBLE_FORECAST_.NE.UNDEF_PARAM_E + CONDITIONS(2) = ENSEMBLE_PAR%NUMBER_OF_FORECASTS_IN_ENSEMBLE_.NE.UNDEF_PARAM_E + CONDITIONS(3) = ENSEMBLE_PAR%SYSTEM_NUMBER_.NE.UNDEF_PARAM_E + CONDITIONS(4) = ENSEMBLE_PAR%METHOD_NUMBER_.NE.UNDEF_PARAM_E + IF ( ANY(CONDITIONS) ) THEN - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( ENSEMBLE_PAR%TYPE_OF_ENSEMBLE_FORECAST_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%TYPE_OF_ENSEMBLE_FORECAST_, CTMP, HOOKS ) - ENDIF - - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'type-of-ensemble-forecast: ', TRIM(ADJUSTL(CTMP)), ' # type of ensemble forecast (default=1)' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'ensemble:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( ENSEMBLE_PAR%NUMBER_OF_FORECASTS_IN_ENSEMBLE_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%NUMBER_OF_FORECASTS_IN_ENSEMBLE_, CTMP, HOOKS ) - ENDIF - - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'number-of-forecasts-in-ensemble: ', TRIM(ADJUSTL(CTMP)), ' # total number of forecasts in ensemble (if not present then it is assumed that the simulation is deterministic)' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - - - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( ENSEMBLE_PAR%SYSTEM_NUMBER_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%SYSTEM_NUMBER_, CTMP, HOOKS ) - ENDIF + IF ( CONDITIONS(1) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%TYPE_OF_ENSEMBLE_FORECAST_, CTMP, HOOKS ) - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'system-number: ', TRIM(ADJUSTL(CTMP)), ' # system number to be set in section2' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'type-of-ensemble-forecast: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - IF ( ENSEMBLE_PAR%METHOD_NUMBER_ .EQ. UNDEF_PARAM_E ) THEN - CTMP='"undefined"' - ELSE - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%METHOD_NUMBER_, CTMP, HOOKS ) - ENDIF + IF ( CONDITIONS(2) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%NUMBER_OF_FORECASTS_IN_ENSEMBLE_, CTMP, HOOKS ) - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'method-number: ', TRIM(ADJUSTL(CTMP)), ' # version number to be set in section2' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'number-of-forecasts-in-ensemble: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + IF ( CONDITIONS(3) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%SYSTEM_NUMBER_, CTMP, HOOKS ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'system-number: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ! convert integer to string + IF ( CONDITIONS(4) ) THEN + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( ENSEMBLE_PAR%METHOD_NUMBER_, CTMP, HOOKS ) + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'method-number: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ! Add an empty line + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! Add an empty line - WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() diff --git a/src/multiom/data-structures/parametrization/geometry_par_mod.F90 b/src/multiom/data-structures/parametrization/geometry_par_mod.F90 index e8c512624..16086d007 100644 --- a/src/multiom/data-structures/parametrization/geometry_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/geometry_par_mod.F90 @@ -11,9 +11,7 @@ MODULE GEOMETRY_PAR_MOD !> Symbols imported from other modules within the project. - USE :: REDUCED_GG_MAP_MOD, ONLY: REDUCED_GG_GEOM_MAP_T - USE :: REGULAR_LL_MAP_MOD, ONLY: REGULAR_LL_GEOM_MAP_T - USE :: SPHERICAL_HARMONICS_MAP_MOD, ONLY: SPHERICAL_HARMONICS_MAP_T + USE :: REPRES_MAP_MOD, ONLY: REPRES_MAP_T IMPLICIT NONE @@ -22,13 +20,9 @@ MODULE GEOMETRY_PAR_MOD !> Geometry parametrization TYPE :: GEOMETRY_PAR_T - LOGICAL :: GG_TO_BE_DEALLOCATED=.FALSE. - LOGICAL :: LL_TO_BE_DEALLOCATED=.FALSE. - LOGICAL :: SH_TO_BE_DEALLOCATED=.FALSE. - TYPE(REDUCED_GG_GEOM_MAP_T), POINTER :: GG => NULL() - TYPE(REGULAR_LL_GEOM_MAP_T), POINTER :: LL => NULL() - TYPE(SPHERICAL_HARMONICS_MAP_T), POINTER :: SH => NULL() + TYPE(REPRES_MAP_T), POINTER :: REPRESENTATIONS => NULL() CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => GEOMETRY_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => GEOMETRY_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_GEOMETRY_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => GEOMETRY_PAR_FREE @@ -41,8 +35,8 @@ MODULE GEOMETRY_PAR_MOD #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'GEOMETRY_PAR_FREE' -PP_THREAD_SAFE FUNCTION GEOMETRY_PAR_FREE( GEOMETRY_PAR, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'GEOMETRY_PAR_INIT' +PP_THREAD_SAFE FUNCTION GEOMETRY_PAR_INIT( GEOMETRY_PAR, HOOKS ) RESULT(RET) !> Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K @@ -90,37 +84,114 @@ PP_THREAD_SAFE FUNCTION GEOMETRY_PAR_FREE( GEOMETRY_PAR, HOOKS ) RESULT(RET) ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - IF ( GEOMETRY_PAR%GG_TO_BE_DEALLOCATED ) THEN - IF ( ASSOCIATED(GEOMETRY_PAR%GG) ) THEN - PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE) GEOMETRY_PAR%GG%FREE( HOOKS ) - DEALLOCATE( GEOMETRY_PAR%GG, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) - ENDIF - ENDIF + ! The geometry map should never be deallocated here + GEOMETRY_PAR%REPRESENTATIONS => NULL() - IF ( GEOMETRY_PAR%LL_TO_BE_DEALLOCATED ) THEN - IF ( ASSOCIATED(GEOMETRY_PAR%LL) ) THEN - PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE) GEOMETRY_PAR%LL%FREE( HOOKS ) - DEALLOCATE( GEOMETRY_PAR%LL, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) - ENDIF - ENDIF + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() - IF ( GEOMETRY_PAR%SH_TO_BE_DEALLOCATED ) THEN - IF ( ASSOCIATED(GEOMETRY_PAR%SH) ) THEN - PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE) GEOMETRY_PAR%SH%FREE( HOOKS ) - DEALLOCATE( GEOMETRY_PAR%SH, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) - ENDIF - ENDIF + ! Exit point (On success) + RETURN - ! Copy the data - GEOMETRY_PAR%GG_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR%LL_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR%SH_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR%GG => NULL() - GEOMETRY_PAR%LL => NULL() - GEOMETRY_PAR%SH => NULL() +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNABLE_TO_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to free the data' ) + CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + ENDIF + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION GEOMETRY_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'GEOMETRY_PAR_FREE' +PP_THREAD_SAFE FUNCTION GEOMETRY_PAR_FREE( GEOMETRY_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(GEOMETRY_PAR_T), INTENT(INOUT) :: GEOMETRY_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 2_JPIB_K + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! The geometry map should never be deallocated here + GEOMETRY_PAR%REPRESENTATIONS => NULL() ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -218,12 +289,7 @@ PP_THREAD_SAFE FUNCTION GEOMETRY_PAR_COPY_FROM( GEOMETRY_PAR_TO, GEOMETRY_PAR_FR PP_SET_ERR_SUCCESS( RET ) ! Copy the data - GEOMETRY_PAR_TO%GG_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR_TO%LL_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR_TO%SH_TO_BE_DEALLOCATED = .FALSE. - GEOMETRY_PAR_TO%GG => GEOMETRY_PAR_FROM%GG - GEOMETRY_PAR_TO%LL => GEOMETRY_PAR_FROM%LL - GEOMETRY_PAR_TO%SH => GEOMETRY_PAR_FROM%SH + GEOMETRY_PAR_TO%REPRESENTATIONS => GEOMETRY_PAR_FROM%REPRESENTATIONS ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -344,61 +410,61 @@ PP_THREAD_SAFE FUNCTION READ_GEOMETRY_PAR_FROM_YAML( GEOMETRY_PAR, CONFIG, HOOKS ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - !> Read the encoder configuration - PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( CONFIG, 'representations', HAS_REPRESENTATIONS, HOOKS ) - - !> Read representations - IF ( HAS_REPRESENTATIONS ) THEN - - !> Read all the subconfigurations - PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_SUBCFG) YAML_GET_SUBCONFIGURATIONS( CONFIG, 'representations', REPRESENTATIONS_CONFIGURATIONS, HOOKS ) - - !> Get the sections size - PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_SUBCFG_SIZE) YAML_GET_CONFIGURATIONS_SIZE( REPRESENTATIONS_CONFIGURATIONS, SZ, HOOKS ) - PP_DEBUG_CRITICAL_COND_THROW( SZ .LE. 0, ERRFLAG_WRONG_NUMBER_OF_REPRESENTATIONS ) - - DO I = 1, SZ - - !> Get the configuration by ID - PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_SUBCFG) YAML_GET_CONFIGURATION_BY_ID( REPRESENTATIONS_CONFIGURATIONS, I, REPRESENTATION_CONFIGURATION, HOOKS ) - - !> Check if the keywords "type" is present - PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( REPRESENTATION_CONFIGURATION, 'type', HAS_TYPE, HOOKS ) - - !> Read the type - IF ( ALLOCATED(CTMP) ) THEN - DEALLOCATE(CTMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) - ENDIF - PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_READ_STRING( REPRESENTATION_CONFIGURATION, 'type', CTMP, HOOKS ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(CTMP), ERRFLAG_UNABLE_TO_READ_CFG ) - - !> Read the type - SELECT CASE (CTMP) - CASE ( 'gg', 'reduced-gaussian' ) - PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_GG_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) - CASE ( 'll', 'regular-latlon' ) - PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_LL_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) - CASE ( 'sh', 'spherical-harmonics' ) - PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_SH_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) - CASE DEFAULT - PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_TYPE ) - END SELECT - - IF ( ALLOCATED(CTMP) ) THEN - DEALLOCATE(CTMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) - PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) - ENDIF - - !> Destroy the configuration object - PP_TRYCALL(ERRFLAG_TEST_CASE_DELETE_ERROR) YAML_DELETE_CONFIGURATION( REPRESENTATION_CONFIGURATION, HOOKS ) - - ENDDO - - !> Destroy the configuration object - PP_TRYCALL(ERRFLAG_TEST_CASE_DELETE_ERROR) YAML_DELETE_CONFIGURATIONS( REPRESENTATIONS_CONFIGURATIONS, HOOKS ) - - ENDIF +! !> Read the encoder configuration +! PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( CONFIG, 'representations', HAS_REPRESENTATIONS, HOOKS ) +! +! !> Read representations +! IF ( HAS_REPRESENTATIONS ) THEN +! +! !> Read all the subconfigurations +! PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_SUBCFG) YAML_GET_SUBCONFIGURATIONS( CONFIG, 'representations', REPRESENTATIONS_CONFIGURATIONS, HOOKS ) +! +! !> Get the sections size +! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_SUBCFG_SIZE) YAML_GET_CONFIGURATIONS_SIZE( REPRESENTATIONS_CONFIGURATIONS, SZ, HOOKS ) +! PP_DEBUG_CRITICAL_COND_THROW( SZ .LE. 0, ERRFLAG_WRONG_NUMBER_OF_REPRESENTATIONS ) +! +! DO I = 1, SZ +! +! !> Get the configuration by ID +! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_SUBCFG) YAML_GET_CONFIGURATION_BY_ID( REPRESENTATIONS_CONFIGURATIONS, I, REPRESENTATION_CONFIGURATION, HOOKS ) +! +! !> Check if the keywords "type" is present +! PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( REPRESENTATION_CONFIGURATION, 'type', HAS_TYPE, HOOKS ) +! +! !> Read the type +! IF ( ALLOCATED(CTMP) ) THEN +! DEALLOCATE(CTMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) +! PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) +! ENDIF +! PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_READ_STRING( REPRESENTATION_CONFIGURATION, 'type', CTMP, HOOKS ) +! PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(CTMP), ERRFLAG_UNABLE_TO_READ_CFG ) +! +! !> Read the type +! SELECT CASE (CTMP) +! CASE ( 'gg', 'reduced-gaussian' ) +! PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_GG_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) +! CASE ( 'll', 'regular-latlon' ) +! PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_LL_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) +! CASE ( 'sh', 'spherical-harmonics' ) +! PP_TRYCALL(ERRFLAG_READ_GG_PAR) DEFINITION_SH_READ_FROM_YAML( REPRESENTATION_CONFIGURATION, GEOMETRY_PAR, HOOKS ) +! CASE DEFAULT +! PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_TYPE ) +! END SELECT +! +! IF ( ALLOCATED(CTMP) ) THEN +! DEALLOCATE(CTMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) +! PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) +! ENDIF +! +! !> Destroy the configuration object +! PP_TRYCALL(ERRFLAG_TEST_CASE_DELETE_ERROR) YAML_DELETE_CONFIGURATION( REPRESENTATION_CONFIGURATION, HOOKS ) +! +! ENDDO +! +! !> Destroy the configuration object +! PP_TRYCALL(ERRFLAG_TEST_CASE_DELETE_ERROR) YAML_DELETE_CONFIGURATIONS( REPRESENTATIONS_CONFIGURATIONS, HOOKS ) +! +! ENDIF ! Trace end of procedure (on success) @@ -423,28 +489,28 @@ PP_THREAD_SAFE FUNCTION READ_GEOMETRY_PAR_FROM_YAML( GEOMETRY_PAR, CONFIG, HOOKS ! Handle different errors SELECT CASE(ERRIDX) - CASE(ERRFLAG_UNABLE_TO_READ_CFG) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to read the configuration' ) - CASE(ERRFLAG_UNABLE_TO_READ_SUBCFG) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to read the subconfigurations' ) - CASE(ERRFLAG_UNABLE_TO_GET_SUBCFG_SIZE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to get the subconfigurations size' ) - CASE(ERRFLAG_UNABLE_TO_GET_SUBCFG) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to get the subconfigurations' ) - CASE(ERRFLAG_WRONG_NUMBER_OF_REPRESENTATIONS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'wrong number of representations' ) - CASE(ERRFLAG_TEST_CASE_DELETE_ERROR) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'error deleting the test case' ) - CASE(ERRFLAG_UNKNOWN_TYPE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unknown type' ) - CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) - IF ( ALLOCATED(ERRMSG) ) THEN - PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) - DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) - ENDIF - CASE(ERRFLAG_READ_GG_PAR) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'error reading the GG geometry' ) +! CASE(ERRFLAG_UNABLE_TO_READ_CFG) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to read the configuration' ) +! CASE(ERRFLAG_UNABLE_TO_READ_SUBCFG) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to read the subconfigurations' ) +! CASE(ERRFLAG_UNABLE_TO_GET_SUBCFG_SIZE) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to get the subconfigurations size' ) +! CASE(ERRFLAG_UNABLE_TO_GET_SUBCFG) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to get the subconfigurations' ) +! CASE(ERRFLAG_WRONG_NUMBER_OF_REPRESENTATIONS) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'wrong number of representations' ) +! CASE(ERRFLAG_TEST_CASE_DELETE_ERROR) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'error deleting the test case' ) +! CASE(ERRFLAG_UNKNOWN_TYPE) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unknown type' ) +! CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) +! IF ( ALLOCATED(ERRMSG) ) THEN +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) +! DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) +! ENDIF +! CASE(ERRFLAG_READ_GG_PAR) +! PP_DEBUG_PUSH_MSG_TO_FRAME( 'error reading the GG geometry' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) END SELECT @@ -467,7 +533,7 @@ END FUNCTION READ_GEOMETRY_PAR_FROM_YAML #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE - +#if 0 #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'DEFINITION_GG_READ_FROM_YAML' PP_THREAD_SAFE FUNCTION DEFINITION_GG_READ_FROM_YAML( CONFIG, GEOMETRY_PAR, HOOKS ) RESULT(RET) @@ -1619,7 +1685,7 @@ PP_THREAD_SAFE FUNCTION READ_LL_GEOMETRY( CONFIG, LL_MAP, HOOKS ) RESULT(RET) END FUNCTION READ_LL_GEOMETRY #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE - +#endif END MODULE GEOMETRY_PAR_MOD #undef PP_SECTION_NAME diff --git a/src/multiom/data-structures/parametrization/level_par_mod.F90 b/src/multiom/data-structures/parametrization/level_par_mod.F90 index c3bc0c158..6c29c5a4d 100644 --- a/src/multiom/data-structures/parametrization/level_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/level_par_mod.F90 @@ -24,9 +24,11 @@ MODULE LEVEL_PAR_MOD LOGICAL :: TO_BE_DEALLOCATED=.FALSE. REAL(KIND=JPRD_K), DIMENSION(:), POINTER :: PV => NULL() CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => LEVEL_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => LEVEL_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_LEVEL_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => LEVEL_PAR_FREE + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => WRITE_LEVEL_PAR_TO_YAML END TYPE !> Whitelist of public symbols (types) @@ -35,6 +37,118 @@ MODULE LEVEL_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'LEVEL_PAR_INIT' +PP_THREAD_SAFE FUNCTION LEVEL_PAR_INIT( LEVEL_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVEL_PAR_T), INTENT(INOUT) :: LEVEL_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STATUS + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Reset the data + IF ( LEVEL_PAR%TO_BE_DEALLOCATED ) THEN + IF ( ASSOCIATED(LEVEL_PAR%PV) ) THEN + DEALLOCATE( LEVEL_PAR%PV, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + NULLIFY( LEVEL_PAR%PV ) + ENDIF + LEVEL_PAR%TO_BE_DEALLOCATED = .FALSE. + ELSE + LEVEL_PAR%TO_BE_DEALLOCATED = .FALSE. + NULLIFY( LEVEL_PAR%PV ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) + IF ( ALLOCATED( ERRMSG)) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STATUS ) + ENDIF + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LEVEL_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'LEVEL_PAR_FREE' PP_THREAD_SAFE FUNCTION LEVEL_PAR_FREE( LEVEL_PAR, HOOKS ) RESULT(RET) @@ -83,13 +197,17 @@ PP_THREAD_SAFE FUNCTION LEVEL_PAR_FREE( LEVEL_PAR, HOOKS ) RESULT(RET) ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! Copy the data + ! Reset the data IF ( LEVEL_PAR%TO_BE_DEALLOCATED ) THEN IF ( ASSOCIATED(LEVEL_PAR%PV) ) THEN DEALLOCATE( LEVEL_PAR%PV, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + NULLIFY( LEVEL_PAR%PV ) ENDIF LEVEL_PAR%TO_BE_DEALLOCATED = .FALSE. + ELSE + LEVEL_PAR%TO_BE_DEALLOCATED = .FALSE. + NULLIFY( LEVEL_PAR%PV ) ENDIF ! Trace end of procedure (on success) @@ -404,6 +522,172 @@ END FUNCTION READ_LEVEL_PAR_FROM_YAML #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WRITE_LEVEL_PAR_TO_YAML' +PP_THREAD_SAFE FUNCTION WRITE_LEVEL_PAR_TO_YAML( LEVEL_PAR, UNIT, OFFSET, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + USE :: LOG_UTILS_MOD, ONLY: TO_STRING + USE :: LOG_UTILS_MOD, ONLY: MAX_STR_LEN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(LEVEL_PAR_T), INTENT(IN) :: LEVEL_PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=MAX_STR_LEN), DIMENSION(:), ALLOCATABLE :: CATMP + INTEGER(KIND=JPIB_K) :: WRITE_STAT + INTEGER(KIND=JPIB_K) :: I + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + LOGICAL :: IS_OPENED + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INVALID_OFFSET = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNIT_NOT_OPENED = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING = 5_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) + + IF ( ASSOCIATED(LEVEL_PAR%PV) ) THEN + + ! convert integer to string + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( LEVEL_PAR%PV, CATMP, HOOKS ) + + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'levels:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'pv: [' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + IF ( ALLOCATED(CATMP) ) THEN + DO I = 1, SIZE(CATMP)-1 + IF ( MOD(I,10) .EQ. 0 ) THEN + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ELSE + WRITE( UNIT, '(A)', ADVANCE='NO', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ENDDO + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(SIZE(CATMP)))) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2)//']' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + DEALLOCATE(CATMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT.NE.0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_INVALID_OFFSET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'invalid offset' ) + CASE(ERRFLAG_UNIT_NOT_OPENED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unit not opened' ) + CASE(ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'write error' ) + CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) + IF ( ALLOCATED( ERRMSG)) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + ENDIF + CASE(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to convert to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION WRITE_LEVEL_PAR_TO_YAML +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + END MODULE LEVEL_PAR_MOD #undef PP_SECTION_NAME #undef PP_SECTION_TYPE diff --git a/src/multiom/data-structures/parametrization/parametrization_enumerators_mod.F90 b/src/multiom/data-structures/parametrization/parametrization_enumerators_mod.F90 index 9e1292af0..c46388b84 100644 --- a/src/multiom/data-structures/parametrization/parametrization_enumerators_mod.F90 +++ b/src/multiom/data-structures/parametrization/parametrization_enumerators_mod.F90 @@ -20,32 +20,33 @@ MODULE PARAMETRIZATION_ENUMERATORS_MOD !> Integer enumerators (general) INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TABLES_VERSION_E=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E=2_JPIB_K !> Integer enumerators (time) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_INITIAL_STEP_E=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_LENGTH_OF_TIME_RANGE_IN_SECONDS_E=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_INITIAL_STEP_E=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_TIME_LENGTH_OF_TIME_RANGE_IN_SECONDS_E=5_JPIB_K !> Integer enumerators (bitmap) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_BITMAP_NUMBER_OF_MISSING_VALUES_E=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_BITMAP_NUMBER_OF_MISSING_VALUES_E=6_JPIB_K !> Integer enumerators (ensemble) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ENSEMBLE_TYPE_OF_ENSEMBLE_FORECAST_E=6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ENSEMBLE_NUMBER_OF_FORECASTS_IN_ENSEMBLE_E=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ENSEMBLE_TYPE_OF_ENSEMBLE_FORECAST_E=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ENSEMBLE_NUMBER_OF_FORECASTS_IN_ENSEMBLE_E=8_JPIB_K !> Integer enumerators (analysis) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ANALYSIS_LENGTH_OF_TIME_WINDOW_E=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_ANALYSIS_LENGTH_OF_TIME_WINDOW_E=9_JPIB_K !> Integer enumerators (satellite) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SATELLITE_SERIES_E=9_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SCALED_FACTOR_OF_CENTRAL_VAWENUMBER_E=10_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SCALED_VALUE_OF_CENTRAL_VAWENUMBER_E=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SATELLITE_SERIES_E=10_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SCALED_FACTOR_OF_CENTRAL_VAWENUMBER_E=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_SATELLITE_SCALED_VALUE_OF_CENTRAL_VAWENUMBER_E=12_JPIB_K !> Integer enumerators (data-representation) - INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E=12_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E=13_JPIB_K !> Total number of integer enumerators - INTEGER(KIND=JPIB_K), PARAMETER :: N_PARINTFLDS=12_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: N_PARINTFLDS=13_JPIB_K ! String enumerators @@ -59,6 +60,7 @@ MODULE PARAMETRIZATION_ENUMERATORS_MOD !> White list of public symbols (enumerators) PUBLIC :: PARINTFLD_TABLES_VERSION_E + PUBLIC :: PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E PUBLIC :: PARINTFLD_TIME_INITIAL_STEP_E PUBLIC :: PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E PUBLIC :: PARINTFLD_TIME_LENGTH_OF_TIME_RANGE_IN_SECONDS_E @@ -141,6 +143,8 @@ PP_THREAD_SAFE FUNCTION IPARINTFLDS2CPARINTFLDS( IPARINTFLDS, CPARINTFLDS, HOOKS SELECT CASE ( IPARINTFLDS ) CASE (PARINTFLD_TABLES_VERSION_E) CPARINTFLDS = 'tables-version' + CASE (PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E) + CPARINTFLDS = 'generating-process-identifier' CASE (PARINTFLD_TIME_INITIAL_STEP_E) CPARINTFLDS = 'initial-step' CASE (PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E) @@ -280,6 +284,8 @@ PP_THREAD_SAFE FUNCTION CPARINTFLDS2IPARINTFLDS( CPARINTFLDS, IPARINTFLDS, HOOKS IPARINTFLDS = PARINTFLD_TABLES_VERSION_E CASE ( 'initial-step' ) IPARINTFLDS = PARINTFLD_TIME_INITIAL_STEP_E + CASE ( 'generating-precess-identifier' ) + IPARINTFLDS = PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E CASE ( 'length-of-time-step-in-seconds' ) IPARINTFLDS = PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E CASE ( 'length-of-time-range-in-seconds' ) diff --git a/src/multiom/data-structures/parametrization/parametrization_mod.F90 b/src/multiom/data-structures/parametrization/parametrization_mod.F90 index 6a4da3726..11383a32b 100644 --- a/src/multiom/data-structures/parametrization/parametrization_mod.F90 +++ b/src/multiom/data-structures/parametrization/parametrization_mod.F90 @@ -36,6 +36,7 @@ MODULE PARAMETRIZATION_MOD ! Tables version INTEGER(KIND=JPIB_K) :: TABLES_VERSION=UNDEF_PARAM_E + INTEGER(KIND=JPIB_K) :: GENERATING_PROCESS_IDENTIFIER=UNDEF_PARAM_E !> Scale factors for the values (used to change units) REAL(KIND=JPRD_K) :: VALUES_SCALE_FACTOR=1.0_JPRD_K @@ -54,6 +55,7 @@ MODULE PARAMETRIZATION_MOD CONTAINS !> Copy from another object + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => PARAMETRIZATION_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => PARAMETRIZATION_FREE PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => PARAMETRIZATION_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_PARAMETRIZATION_FROM_YAML @@ -77,6 +79,7 @@ MODULE PARAMETRIZATION_MOD !> print PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: PRINT => PARAMETRIZATION_PRINT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: TO_JSON => PARAMETRIZATION_TO_JSON + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => PARAMETRIZATION_TO_YAML END TYPE @@ -86,6 +89,154 @@ MODULE PARAMETRIZATION_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PARAMETRIZATION_INIT' +PP_THREAD_SAFE FUNCTION PARAMETRIZATION_INIT( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PARAMETRIZATION_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_TIME=0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_GEOMETRY=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_LEVELS=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_ENSEMBLE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_ANALYSIS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_WAVE=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_SATELLITE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_DATA_REPRESENTATION=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INIT_BITMAP=8_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Tables version + THIS%TABLES_VERSION=UNDEF_PARAM_E + THIS%GENERATING_PROCESS_IDENTIFIER=UNDEF_PARAM_E + + ! Scale factors for the values (used to change units) + THIS%VALUES_SCALE_FACTOR=1.0_JPRD_K + + ! INIT the geometry + PP_TRYCALL(ERRFLAG_INIT_TIME) THIS%TIME%INIT( HOOKS ) + + ! INIT the geometry + PP_TRYCALL(ERRFLAG_INIT_GEOMETRY) THIS%GEOMETRY%INIT( HOOKS ) + + ! INIT the levels + PP_TRYCALL(ERRFLAG_INIT_LEVELS) THIS%LEVELS%INIT( HOOKS ) + + ! INIT the ensemble + PP_TRYCALL(ERRFLAG_INIT_ENSEMBLE) THIS%ENSEMBLE%INIT( HOOKS ) + + ! INIT the ensemble + PP_TRYCALL(ERRFLAG_INIT_ANALYSIS) THIS%ANALYSIS%INIT( HOOKS ) + + ! INIT the wave + PP_TRYCALL(ERRFLAG_INIT_WAVE) THIS%WAVE%INIT( HOOKS ) + + ! INIT the satellite + PP_TRYCALL(ERRFLAG_INIT_SATELLITE) THIS%SATELLITE%INIT( HOOKS ) + + ! INIT the data-representation + PP_TRYCALL(ERRFLAG_INIT_DATA_REPRESENTATION) THIS%DATA_REPRESENTATION%INIT( HOOKS ) + + ! INIT the bitmap + PP_TRYCALL(ERRFLAG_INIT_BITMAP) THIS%BITMAP%INIT( HOOKS ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_INIT_TIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init time' ) + CASE(ERRFLAG_INIT_GEOMETRY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init geometry' ) + CASE(ERRFLAG_INIT_LEVELS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init levels' ) + CASE(ERRFLAG_INIT_ENSEMBLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init ensemble' ) + CASE(ERRFLAG_INIT_ANALYSIS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init analysis' ) + CASE(ERRFLAG_INIT_WAVE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init wave' ) + CASE(ERRFLAG_INIT_SATELLITE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init satellite' ) + CASE(ERRFLAG_INIT_DATA_REPRESENTATION) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init data-representation' ) + CASE(ERRFLAG_INIT_BITMAP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init bitmap' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PARAMETRIZATION_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'PARAMETRIZATION_FREE' @@ -141,9 +292,10 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_FREE( THIS, HOOKS ) RESULT(RET) ! Tables version THIS%TABLES_VERSION=UNDEF_PARAM_E + THIS%GENERATING_PROCESS_IDENTIFIER=UNDEF_PARAM_E ! Scale factors for the values (used to change units) - THIS%VALUES_SCALE_FACTOR=0.0_JPRD_K + THIS%VALUES_SCALE_FACTOR=1.0_JPRD_K ! Free the geometry PP_TRYCALL(ERRFLAG_FREE_TIME) THIS%TIME%FREE( HOOKS ) @@ -294,6 +446,7 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_COPY_FROM( THIS, OTHER, HOOKS ) RESULT(R ! Copy the non categorized values (table version) THIS%TABLES_VERSION = OTHER%TABLES_VERSION + THIS%GENERATING_PROCESS_IDENTIFIER = OTHER%GENERATING_PROCESS_IDENTIFIER ! Copy the scale factor of the values THIS%VALUES_SCALE_FACTOR = OTHER%VALUES_SCALE_FACTOR @@ -848,6 +1001,7 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_SET_INT( THIS, ID, VALUE, HOOKS ) RESULT USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: PARINTFLD_TABLES_VERSION_E + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: PARINTFLD_TIME_INITIAL_STEP_E USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: PARINTFLD_TIME_LENGTH_OF_TIME_RANGE_IN_SECONDS_E @@ -903,6 +1057,8 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_SET_INT( THIS, ID, VALUE, HOOKS ) RESULT SELECT CASE ( ID ) CASE ( PARINTFLD_TABLES_VERSION_E ) THIS%TABLES_VERSION = VALUE + CASE ( PARINTFLD_GENERATING_PROCESS_IDENTIFIER_E ) + THIS%GENERATING_PROCESS_IDENTIFIER = VALUE CASE ( PARINTFLD_TIME_INITIAL_STEP_E ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PAR) THIS%TIME%SET_INITIAL_STEP( VALUE, HOOKS ) CASE ( PARINTFLD_TIME_LENGTH_OF_TIME_STEP_IN_SECONDS_E ) @@ -923,7 +1079,8 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_SET_INT( THIS, ID, VALUE, HOOKS ) RESULT ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PAR) THIS%SATELLITE%SET_SCALED_FACTOR_OF_CENTRAL_VAWENUMBER( VALUE, HOOKS ) ! CASE ( PARINTFLD_SATELLITE_SCALED_VALUE_OF_CENTRAL_VAWENUMBER_E ) ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PAR) THIS%SATELLITE%SET_SCALED_VALUE_OF_CENTRAL_VAWENUMBER( VALUE, HOOKS ) - ! CASE ( PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E ) + CASE ( PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E ) + THIS%DATA_REPRESENTATION%BITS_PER_VALUE_ = VALUE ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PAR) THIS%DATA_REPRESENTATION%SET_BITS_PER_VALUE( VALUE, HOOKS ) CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_PAR ) @@ -1267,8 +1424,9 @@ PP_THREAD_SAFE FUNCTION PARAMETRIZATION_GET_INT( THIS, ID, VALUE, HOOKS ) RESULT ! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_PAR) THIS%SATELLITE%GET_SCALED_FACTOR_OF_CENTRAL_VAWENUMBER( VALUE, HOOKS ) ! CASE ( PARINTFLD_SATELLITE_SCALED_VALUE_OF_CENTRAL_VAWENUMBER_E ) ! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_PAR) THIS%SATELLITE%GET_SCALED_VALUE_OF_CENTRAL_VAWENUMBER( VALUE, HOOKS ) - ! CASE ( PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E ) - ! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_PAR) THIS%DATA_REPRESENTATION%GET_BITS_PER_VALUE( VALUE, HOOKS ) + CASE ( PARINTFLD_DATA_REPRESENTATION_BITS_PER_VALUE_E ) + VALUE = THIS%DATA_REPRESENTATION%BITS_PER_VALUE_ + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_GET_PAR) THIS%DATA_REPRESENTATION%GET_BITS_PER_VALUE( VALUE, HOOKS ) CASE DEFAULT PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_PAR ) END SELECT @@ -1614,7 +1772,7 @@ PP_THREAD_SAFE FUNCTION READ_PARAMETRIZATION_FROM_YAML( PARAMETRIZATION, CONFIG, PARAMETRIZATION%VALUES_SCALE_FACTOR = 1.0_JPRD_K ENDIF - ! Read the data representation parameters + ! Read the table version parameters PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( PARAMETRIZATION_CONFIGURATION, 'tables-version', HAS_KEY, HOOKS ) IF ( HAS_KEY ) THEN PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_READ_INTEGER( PARAMETRIZATION_CONFIGURATION, 'tables-versions', PARAMETRIZATION%TABLES_VERSION, HOOKS ) @@ -1622,6 +1780,14 @@ PP_THREAD_SAFE FUNCTION READ_PARAMETRIZATION_FROM_YAML( PARAMETRIZATION, CONFIG, PARAMETRIZATION%TABLES_VERSION = UNDEF_PARAM_E ENDIF + ! Read the generating process identifier parameters + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_CONFIGURATION_HAS_KEY( PARAMETRIZATION_CONFIGURATION, 'generating-process-identifier', HAS_KEY, HOOKS ) + IF ( HAS_KEY ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_CFG) YAML_READ_INTEGER( PARAMETRIZATION_CONFIGURATION, 'generating-process-identifier', PARAMETRIZATION%GENERATING_PROCESS_IDENTIFIER, HOOKS ) + ELSE + PARAMETRIZATION%TABLES_VERSION = UNDEF_PARAM_E + ENDIF + ! Read nested types PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_TIME) PARAMETRIZATION%TIME%READ_FROM_YAML( PARAMETRIZATION_CONFIGURATION, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_GEOMETRY) PARAMETRIZATION%GEOMETRY%READ_FROM_YAML( PARAMETRIZATION_CONFIGURATION, HOOKS ) @@ -1707,6 +1873,186 @@ END FUNCTION READ_PARAMETRIZATION_FROM_YAML #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PARAMETRIZATION_TO_YAML' +PP_THREAD_SAFE FUNCTION PARAMETRIZATION_TO_YAML( THIS, UNIT, OFFSET, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: N_PARINTFLDS + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: IPARINTFLDS2CPARINTFLDS + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: N_PARSTRFLDS + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: IPARSTRINGFLDS2CPARSTRINGFLDS + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: N_PARFLOATFLDS + USE :: PARAMETRIZATION_ENUMERATORS_MOD, ONLY: IPARFLOATFLDS2CPARFLOATFLDS + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(PARAMETRIZATION_T), INTENT(IN) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local parameters + CHARACTER(LEN=32) :: CTMP + INTEGER(KIND=JPIB_K) :: WRITE_STAT + LOGICAL :: UNIT_OPENED + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNIT_NOT_OPENED=0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IOSTATUS_NOT_ZERO=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_TIME=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_LEVEL=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_BITMAP=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_ENSEMBLE=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_ANALYSIS=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_WAVE=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_SATELLITE=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_DATA_REPRESENTATION=9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_GEOMETRY=10_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Erro handling + INQUIRE(UNIT=UNIT, OPENED=UNIT_OPENED) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.UNIT_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET)//'parametrization:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + + + ! Print "TablesVersion" + IF ( THIS%TABLES_VERSION .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%TABLES_VERSION + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'tables-version: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print "GeneratingProcessIdentifier" + IF ( THIS%GENERATING_PROCESS_IDENTIFIER .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(I8)',IOSTAT=WRITE_STAT) THIS%GENERATING_PROCESS_IDENTIFIER + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'generating-process-identifier: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print "ValuesScaleFactor" + IF ( THIS%VALUES_SCALE_FACTOR .NE. UNDEF_PARAM_E ) THEN + CTMP = REPEAT(' ',32) + WRITE(CTMP,'(F11.4)',IOSTAT=WRITE_STAT) THIS%VALUES_SCALE_FACTOR + WRITE(UNIT,'(A)',IOSTAT=WRITE_STAT) REPEAT(' ',OFFSET+2)//'values-scale-factor: '//TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT .NE. 0, ERRFLAG_IOSTATUS_NOT_ZERO ) + ENDIF + + ! Print sub-parametrizations + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_TIME) THIS%TIME%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_LEVEL) THIS%LEVELS%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_BITMAP) THIS%BITMAP%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_ENSEMBLE) THIS%ENSEMBLE%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_ANALYSIS) THIS%ANALYSIS%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_WAVE) THIS%WAVE%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_SATELLITE) THIS%SATELLITE%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_DATA_REPRESENTATION) THIS%DATA_REPRESENTATION%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_WRITE_GEOMETRY) THIS%GEOMETRY%WRITE_TO_YAML( UNIT, OFFSET+2, HOOKS ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNIT_NOT_OPENED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unit not opened' ) + CASE(ERRFLAG_IOSTATUS_NOT_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'iostat not zero' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_TIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write time' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_LEVEL) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write level' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_BITMAP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write bitmap' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_ENSEMBLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write ensemble' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_ANALYSIS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write analysis' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_WAVE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write wave' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_SATELLITE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write satellite' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_DATA_REPRESENTATION) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write data representation' ) + CASE(ERRFLAG_UNABLE_TO_WRITE_GEOMETRY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write geometry' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PARAMETRIZATION_TO_YAML +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + END MODULE PARAMETRIZATION_MOD #undef PP_SECTION_NAME #undef PP_SECTION_TYPE diff --git a/src/multiom/data-structures/parametrization/repres_map_mod.F90 b/src/multiom/data-structures/parametrization/repres_map_mod.F90 new file mode 100644 index 000000000..3a4fddf8c --- /dev/null +++ b/src/multiom/data-structures/parametrization/repres_map_mod.F90 @@ -0,0 +1,5026 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + +! Definition of the module +#define PP_FILE_NAME 'repres_map_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'REPRES_MAP_MOD' +MODULE REPRES_MAP_MOD + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + +IMPLICIT NONE + +!> @brief Default visibility of the module +PRIVATE + +!> @brief Flag used to enable the tree balancing +LOGICAL, PARAMETER :: RED_BLACK_BALANCING=.TRUE. +INTEGER(KIND=JPIB_K), PARAMETER :: REPRES_KEY_LENGTH=16_JPIB_K + +!> @brief Datatype used to to store a node of the tree +TYPE :: REPRES_NODE_T + + !> Key + CHARACTER(LEN=REPRES_KEY_LENGTH) :: KEY=REPEAT(' ',REPRES_KEY_LENGTH) + + !> Value + LOGICAL :: TO_BE_DEALLOCATED = .TRUE. + CLASS(REPRES_A), POINTER :: REPRES_ => NULL() + + !> Color + LOGICAL :: RED = .FALSE. + + !> Index used to dump the graph + INTEGER(KIND=JPIB_K) :: IDX + + !> Pointer to the parent node + TYPE(REPRES_NODE_T), POINTER :: PARENT => NULL() + + !> Pointer to the lef subtree + TYPE(REPRES_NODE_T), POINTER :: LEFT => NULL() + + !> Pointer to the right subtree + TYPE(REPRES_NODE_T), POINTER :: RIGHT => NULL() + +END TYPE + + +!> @brief Datatype used to to store the entire map +TYPE :: REPRES_MAP_T + + !> Pointer to the class + PRIVATE + + !> Pointer to the root node + TYPE(REPRES_NODE_T), POINTER :: ROOT => NULL() + + !> Size of the map + INTEGER(KIND=JPIB_K) :: SIZE = -1_JPIB_K + +CONTAINS + + !> Public methods + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => REPRES_INIT + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => REPRES_FREE + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: MIN => REPRES_MINIMUM + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: MAX => REPRES_MAXIMUM + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: PUSH => REPRES_PUSH + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: MATCH => REPRES_MATCH + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: GET => REPRES_GET + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: DELETE => REPRES_REMOVE + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: KEYS => REPRES_GET_SORTED_KEYS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: LIST => REPRES_LIST + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: PRINT => REPRES_PRINT + +END TYPE + + +!> @brief Node used as terminal symbol +TYPE(REPRES_NODE_T), TARGET :: NIL + +!> Whitelist of public symbols +PUBLIC :: REPRES_KEY_LENGTH +PUBLIC :: REPRES_MAP_T + +CONTAINS + + + + +!> +!> @brief Inserts a key-value pair into a map (Red Black Tree). +!> +!> This subroutine comares two keys and returns a flag indicating if the +!> first key is equal to the second key. +!> +!> @param [in] KEY1 The first key to be compared +!> @param [in] KEY2 The second key to be compares +!> @param [out] IS_EQUAL Flag indicating if the keys are equal +!> @param [inout] HOOKS The hooks structure +!> +!> @return Integer error code (`RET`) indicating the success or failure of the initialization. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'KEY_EQUAL_TO' +PP_THREAD_SAFE FUNCTION KEY_EQUAL_TO( KEY1, KEY2, IS_EQUAL, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY1 + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY2 + LOGICAL, INTENT(OUT) :: IS_EQUAL + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_COMPARE_ERROR=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Check if the keys are equal (the check depends on the options) + IS_EQUAL = (KEY1 .EQ. KEY2) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION KEY_EQUAL_TO +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Inserts a key-value pair into a map (Red Black Tree). +!> +!> This subroutine comares two keys and returns a flag indicating if the +!> first key is lower than the second key. +!> +!> @param [in] KEY1 The first key to be compared +!> @param [in] KEY2 The second key to be compares +!> @param [out] IS_LOWER_THAN Flag indicating if the first key is +!> lower than the second key +!> @param [inout] HOOKS The hooks structure +!> +!> @return Integer error code (`RET`) indicating the success or failure of the initialization. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'KEY_LOWER_THAN' +PP_THREAD_SAFE FUNCTION KEY_LOWER_THAN( KEY1, KEY2, IS_LOWER_THAN, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY1 + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY2 + LOGICAL, INTENT(OUT) :: IS_LOWER_THAN + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_COMPARE_ERROR=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Check if the keys are equal (the check depends on the options) + IS_LOWER_THAN = (KEY1 .LT. KEY2) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION KEY_LOWER_THAN +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Inserts a key-value pair into a map (Red Black Tree). +!> +!> This subroutine inserts a key-value pair into a map data structure. +!> It navigates the map structure and inserts the provided key and value appropriately. +!> +!> @param [inout] ROOT Pointer to the root node of the map. +!> The map structure will be modified to include +!> the new key-value pair. +!> @param [in] KEY The key to be inserted into the map. +!> +!> @note This subroutine assumes that the map data structure is properly initialized. +!> It is the responsibility of the caller to ensure that the map is correctly set up +!> +!> @warning This subroutine does not perform any action if the specified key is already found in the map. +!> It is the responsibility of the caller to handle such scenarios appropriately. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INSERT_NODE' +PP_THREAD_SAFE FUNCTION INSERT_NODE( ROOT, KEY, REPRES, TO_BE_DEALLOCATED, INSERTED, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + CLASS(REPRES_A), POINTER, INTENT(IN) :: REPRES + LOGICAL, INTENT(IN) :: TO_BE_DEALLOCATED + LOGICAL, INTENT(OUT) :: INSERTED + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: INSERTION_POINT + LOGICAL :: FOUND + LOGICAL :: KEY_LT + LOGICAL :: ROOT_IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ALLOCATE_NODE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INITIALIZE_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FIXUP_INSERT=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SEARCH_NODE=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_KEY_LT_FAILURE=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ROOT_NOT_ASSOCIATED=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ENCODERS_NOT_ASSOCIATED=9_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + !> Error handling (In case of empty map Root still needs to be associated to NIL) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ASSOCIATED( ROOT ), ERRFLAG_ROOT_NOT_ASSOCIATED ) + + ! Initialization of the insertion flag + INSERTED =.FALSE. + + ! Logging + PP_LOG_DEVELOP_STR( 'PUSH :: '//TRIM(ADJUSTL(KEY))//'::<'//TRIM(ADJUSTL(REPRES%DATA_REPRESENTATION_TYPE))//','//TRIM(ADJUSTL(REPRES%NAME))//'>' ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( ROOT_IS_LEAF ) THEN + + ! Map is empty + INSERTED =.TRUE. + PP_TRYCALL(ERRFLAG_UNABLE_TO_ALLOCATE_NODE) ALLOCATE_NODE( ROOT, HOOKS ) + INSERTION_POINT => NIL + PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_NODE) NODE_INIT( ROOT, INSERTION_POINT, KEY, & +& REPRES, TO_BE_DEALLOCATED, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_FIXUP_INSERT) INSERT_FIXUP( ROOT, ROOT, HOOKS ) + INSERTION_POINT => ROOT + ELSE + + ! Map not empty + INSERTION_POINT => NIL + PP_TRYCALL(ERRFLAG_UNABLE_TO_SEARCH_NODE) SEARCH_NODE( ROOT, INSERTION_POINT, KEY, FOUND, HOOKS ) + + IF ( .NOT.FOUND ) THEN + ! If the node is not in the map then insert it + INSERTED =.TRUE. + PP_TRYCALL(ERRFLAG_KEY_LT_FAILURE) KEY_LOWER_THAN( KEY, INSERTION_POINT%KEY, KEY_LT, HOOKS ) + IF ( KEY_LT ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_ALLOCATE_NODE) ALLOCATE_NODE( INSERTION_POINT%LEFT, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_NODE) NODE_INIT( INSERTION_POINT%LEFT, INSERTION_POINT, & +& KEY, REPRES, TO_BE_DEALLOCATED, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_FIXUP_INSERT) INSERT_FIXUP( ROOT, INSERTION_POINT%LEFT, HOOKS ) + ELSE + PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_NODE) ALLOCATE_NODE( INSERTION_POINT%RIGHT, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_ALLOCATE_NODE) NODE_INIT( INSERTION_POINT%RIGHT, INSERTION_POINT, & +& KEY, REPRES, TO_BE_DEALLOCATED, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_FIXUP_INSERT) INSERT_FIXUP( ROOT, INSERTION_POINT%RIGHT, HOOKS ) + ENDIF + ELSE + ! If the node is in the map then return the value + INSERTED =.FALSE. + ENDIF + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_ALLOCATE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to allocate node' ) + CASE (ERRFLAG_UNABLE_TO_INITIALIZE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to initialize node' ) + CASE (ERRFLAG_UNABLE_TO_FIXUP_INSERT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to fixup insert' ) + CASE (ERRFLAG_UNABLE_TO_SEARCH_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to search node' ) + CASE (ERRFLAG_KEY_LT_FAILURE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'key lower than failure' ) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_ROOT_NOT_ASSOCIATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'root not associated' ) + CASE (ERRFLAG_ENCODERS_NOT_ASSOCIATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'encoders not associated' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION INSERT_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Removes a key-value pair from a map. +!> +!> This subroutine removes a key-value pair from a map data structure. +!> It searches for the specified key in the map structure and removes the corresponding entry. +!> +!> @param [inout] ROOT Pointer to the root node of the map. +!> The map structure will be modified to exclude the specified key-value pair. +!> @param [in] KEY The key whose associated value is to be removed from the map. +!> +!> @note This subroutine assumes that the map data structure is properly initialized. +!> It is the responsibility of the caller to ensure that the map is correctly set up +!> +!> @warning This subroutine does not perform any action if the specified key is not found in the map. +!> It is the responsibility of the caller to handle such scenarios appropriately. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'DELETE_NODE' +PP_THREAD_SAFE FUNCTION DELETE_NODE( ROOT, KEY, FOUND, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + LOGICAL, INTENT(OUT) :: FOUND + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: INSERTION_POINT + LOGICAL :: ROOT_IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_REMOVE_NODE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ERRFLAG_UNABLE_TO_SEARCH_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( .NOT.ROOT_IS_LEAF ) THEN + PP_TRYCALL(ERRFLAG_ERRFLAG_UNABLE_TO_SEARCH_NODE) SEARCH_NODE( ROOT, INSERTION_POINT, KEY, FOUND, HOOKS ) + IF ( FOUND ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_REMOVE_NODE) REMOVE_NODE( ROOT, INSERTION_POINT, HOOKS ) + ENDIF + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_REMOVE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to remove node' ) + CASE (ERRFLAG_ERRFLAG_UNABLE_TO_SEARCH_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to search node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION DELETE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Recursively frees memory associated with a map node. +!> +!> This subroutine recursively frees memory associated with a map node and its descendants. +!> It traverses the map structure starting from the specified node and deallocates memory for each node encountered. +!> +!> @param [inout] CURRENT Pointer to the current node in the map structure. +!> The subroutine frees memory associated with this node and its descendants. +!> @param [out] ERR Output parameter indicating the error status of the operation. +!> A non-zero value indicates an error occurred during the memory deallocation process. +!> +!> @note This subroutine assumes that the map nodes and associated memory are properly initialized. +!> It is the responsibility of the caller to ensure that the map structure is correctly set up. +!> +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'FREE_NODE' +RECURSIVE FUNCTION FREE_NODE( CURRENT, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: CURRENT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_NODE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Implementation + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( CURRENT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + ! Deallocate left subtree. + PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_NODE) FREE_NODE( CURRENT%LEFT, HOOKS ) + + ! Deallocate right subtree. + PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_NODE) FREE_NODE( CURRENT%RIGHT, HOOKS ) + + ! Free memory + PP_TRYCALL(ERRFLAG_UNABLE_TO_DEALLOCATE_NODE) DEALLOCATE_NODE( CURRENT, HOOKS ) + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_FREE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to free node' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION FREE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> @brief Searches for a key in a map structure. +!> +!> This subroutine searches for a specified key in a map structure starting from a given node. +!> It traverses the map structure recursively, comparing keys until the desired key is found or the search terminates. +!> +!> @param [inout] ROOT Pointer to the root node of the map structure. +!> The search operation starts from this node. +!> @param [inout] CURRENT Pointer to the current node being evaluated during the search operation. +!> This pointer is updated during the recursive traversal of the map structure. +!> @param [in] KEY The key to search for in the map structure. +!> @param [out] ERR Output parameter indicating the status of the search operation. +!> A non-zero value indicates an error occurred during the search process, such as key not found. +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> It is the responsibility of the caller to ensure that the map is correctly set up. +!> +!> @warning This subroutine may modify the value of the `CURRENT` pointer during the search process. +!> The `ERR` parameter will be set to a non-zero value if the key is not found during the search. +!> It is the responsibility of the caller to handle such scenarios appropriately. +!> The caller should check the value of `ERR` after calling this subroutine to determine the outcome of the search. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SEARCH_NODE' +PP_THREAD_SAFE FUNCTION SEARCH_NODE( ROOT, CURRENT, KEY, FOUND, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: CURRENT + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + LOGICAL, INTENT(OUT) :: FOUND + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: ROOT_IS_LEAF + LOGICAL :: IS_LEAF + LOGICAL :: KEY_LT + LOGICAL :: KEY_GT + LOGICAL :: KEY_EQ + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_KEY_LT_FAILURE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_KEY_EQ_FAILURE=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialization. + FOUND = .TRUE. + CURRENT => ROOT + + ! Map is empty. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( ROOT_IS_LEAF ) THEN + + FOUND = .FALSE. + + ELSE + + ! Perform the search loop + SearchLoop: DO + + !> Handle exit conditions + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( CURRENT, IS_LEAF, HOOKS ) + PP_TRYCALL(ERRFLAG_KEY_EQ_FAILURE) KEY_EQUAL_TO( KEY, CURRENT%KEY, KEY_EQ, HOOKS ) + + IF ( IS_LEAF .OR. KEY_EQ ) THEN + EXIT SearchLoop + ENDIF + + ! Left subtree + PP_TRYCALL(ERRFLAG_KEY_LT_FAILURE) KEY_LOWER_THAN( KEY, CURRENT%KEY, KEY_LT, HOOKS ) + IF ( KEY_LT ) THEN + + !> Check if the current node is a leaf + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( CURRENT%LEFT, IS_LEAF, HOOKS ) + + !> Depending if it si a leaf or not, move to the left or exit + IF ( .NOT.IS_LEAF ) THEN + + CURRENT => CURRENT%LEFT + CYCLE SearchLoop + + ELSE + + FOUND = .FALSE. + EXIT SearchLoop + + ENDIF + + ! Node Found + PP_TRYCALL(ERRFLAG_KEY_EQ_FAILURE) KEY_EQUAL_TO( KEY, CURRENT%KEY, KEY_EQ, HOOKS ) + ELSEIF ( KEY_EQ ) THEN + + FOUND = .TRUE. + EXIT SearchLoop + + ! Right subtree + ELSE + + !> Check if the current node is a leaf + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( CURRENT%RIGHT, IS_LEAF, HOOKS ) + + !> Depending if it si a leaf or not, move to the right or exit + IF ( .NOT.IS_LEAF ) THEN + + CURRENT => CURRENT%RIGHT + + CYCLE SearchLoop + + ELSE + + FOUND = .FALSE. + EXIT SearchLoop + + ENDIF + + ENDIF + + ENDDO SearchLoop + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_KEY_LT_FAILURE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'key lower than failure' ) + CASE (ERRFLAG_KEY_EQ_FAILURE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'key equal to failure' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION SEARCH_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Initializes a map node with the provided information. +!> +!> This subroutine initializes a map node with the specified parent, key, and value. +!> It sets the internal attributes of the node accordingly. +!> +!> @param [inout] THIS The map node to be initialized. +!> @param [in] PARENT Pointer to the parent node of the current node. +!> This parameter can be NULL if the node has no parent. +!> @param [in] KEY The key associated with the node. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'NODE_INIT' +PP_THREAD_SAFE FUNCTION NODE_INIT( THIS, PARENT, KEY, REPRES, TO_BE_DEALLOCATED, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), INTENT(INOUT) :: THIS + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: PARENT + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + CLASS(REPRES_A), POINTER, INTENT(IN) :: REPRES + LOGICAL, INTENT(IN) :: TO_BE_DEALLOCATED + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_COPY_KEY_FAILURE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + !> Node management initialization + IF ( .NOT. ASSOCIATED(PARENT) ) THEN + NULLIFY(THIS%PARENT) + ELSE + THIS%PARENT => PARENT + ENDIF + THIS%RIGHT => NIL + THIS%LEFT => NIL + THIS%RED = .TRUE. + THIS%KEY = KEY + THIS%IDX = -99 + + !> Key initialization + THIS%KEY = KEY + + !> Allocate the mappers + THIS%TO_BE_DEALLOCATED = TO_BE_DEALLOCATED + THIS%REPRES_ => REPRES + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_COPY_KEY_FAILURE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to copy the key' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION NODE_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Allocate a new node in the map. +!> +!> This subroutine is used to allocate a new node in the map +!> +!> @param [inout] CURRENT The map node to be allocated. +!> +!> @note this function is a placehlder for a future stack custom +!> allocator. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ALLOCATE_NODE' +PP_THREAD_SAFE FUNCTION ALLOCATE_NODE( CURRENT, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: CURRENT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: ALLOC_STATUS + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ALLOCATE_NODE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Allocate, initialize and fill the fields. + NULLIFY( CURRENT ) + ALLOCATE( CURRENT, STAT=ALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STATUS.NE.0, ERRFLAG_UNABLE_TO_ALLOCATE_NODE ) + + ! Connect pointers. + CURRENT%LEFT => NIL + CURRENT%RIGHT => NIL + CURRENT%PARENT => NIL + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_ALLOCATE_NODE) + IF ( .NOT.ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error allocating encoders_map node: ' ) + ELSE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error allocating encoders_map node: '//TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE(ERRMSG) + ENDIF + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ALLOCATE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Deallocate a new node in the map. +!> +!> This subroutine is used to deallocate a new node in the map +!> +!> @param [inout] CURRENT The map node to be deallocated. +!> @param [out] ERR Error in deallocation +!> +!> @note this function is a placehlder for a future stack custom +!> allocator. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'DEALLOCATE_NODE' +PP_THREAD_SAFE FUNCTION DEALLOCATE_NODE( X, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: X + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: DEALLOC_STATUS + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE_NODE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_KEY=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_VAL=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Check node is associated + IF ( ASSOCIATED( X ) ) THEN + + ! Free memory of the key and payload + X%KEY = REPEAT(' ',REPRES_KEY_LENGTH) + + ! Free mappers + IF ( ASSOCIATED( X%REPRES_ ) ) THEN + IF ( X%TO_BE_DEALLOCATED ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_VAL) X%REPRES_%FREE( HOOKS ) + DEALLOCATE( X%REPRES_, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS.NE.0, ERRFLAG_UNABLE_TO_FREE_VAL ) + ENDIF + X%TO_BE_DEALLOCATED = .TRUE. + NULLIFY( X%REPRES_ ) + ENDIF + + ! Free node memory. + DEALLOCATE( X, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS.NE.0, ERRFLAG_UNABLE_TO_DEALLOCATE_NODE ) + NULLIFY( X ) + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error deallocating encoders_map node' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE(ERRMSG) + ENDIF + CASE (ERRFLAG_UNABLE_TO_FREE_KEY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error freeing key' ) + CASE (ERRFLAG_UNABLE_TO_FREE_VAL) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error freeing value' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION DEALLOCATE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Restores Red-Black properties after insertion. +!> +!> This subroutine performs fix-up operations to restore the Red-Black properties +!> of the map structure after a node insertion. +!> +!> @param [inout] ROOT Pointer to the root node of the map structure. +!> The map structure might be modified during the fix-up process. +!> @param [inout] CUR Pointer to the current node that requires fix-up operations. +!> +!> @note This subroutine assumes that the map structure is a Red-Black tree +!> and that the node insertion has potentially violated its properties. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INSERT_FIXUP' +PP_THREAD_SAFE FUNCTION INSERT_FIXUP( ROOT, CUR, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: CUR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: Y + TYPE(REPRES_NODE_T), POINTER :: X + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ROTATE_LEFT=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ROTATE_RIGHT=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialization of local variables + X => NULL() + Y => NULL() + + !Balancing tree. + CUR%RED = .TRUE. + + X => CUR + + ! Climbing the tree to fix colors + DO WHILE ( X%PARENT%RED .AND. .NOT.ASSOCIATED( X, ROOT ) ) + + IF ( ASSOCIATED( X%PARENT%PARENT%LEFT, X%PARENT ) ) THEN + + Y => X%PARENT%PARENT%RIGHT ! UNCLE + + IF ( Y%RED ) THEN + + Y%RED = .FALSE. + + X%PARENT%RED = .FALSE. + + X%PARENT%PARENT%RED = .TRUE. + + X => X%PARENT%PARENT + + ELSE + + IF ( ASSOCIATED( X, X%PARENT%RIGHT ) ) THEN + + X => X%PARENT + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_LEFT) ROTATE_LEFT( ROOT, X, HOOKS ) + + ENDIF + + X%PARENT%RED = .FALSE. + + X%PARENT%PARENT%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_RIGHT) ROTATE_RIGHT( ROOT, X%PARENT%PARENT, HOOKS ) + + ENDIF + + ELSE + + !...Must be right grandchild to get here. + Y => X%PARENT%PARENT%LEFT ! AUNT + + IF ( Y%RED ) THEN + + Y%RED = .FALSE. + + X%PARENT%RED = .FALSE. + + X%PARENT%PARENT%RED = .TRUE. + + X => X%PARENT%PARENT + + ELSE + + IF ( ASSOCIATED( X, X%PARENT%LEFT ) ) THEN + + X => X%PARENT + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_RIGHT) ROTATE_RIGHT( ROOT, X, HOOKS ) + + ENDIF + + X%PARENT%RED = .FALSE. + + X%PARENT%PARENT%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_LEFT) ROTATE_LEFT( ROOT, X%PARENT%PARENT, HOOKS ) + + ENDIF + + ENDIF + + ENDDO + + ! Change color of the root + ROOT%RED = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_ROTATE_LEFT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to rotate left' ) + CASE (ERRFLAG_UNABLE_TO_ROTATE_RIGHT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to rotate right' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION INSERT_FIXUP +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Performs a left rotation on a binary search tree. +!> +!> This subroutine performs a left rotation operation on a binary search tree. +!> It adjusts the structure of the tree to maintain the properties of the binary search tree. +!> +!> @param [inout] ROOT Pointer to the root node of the binary search tree. +!> The tree structure might be modified during the rotation process. +!> @param [inout] X_ Pointer to the node around which the left rotation is performed. +!> +!> @note This subroutine assumes that the binary search tree structure is properly initialized +!> and that the left rotation operation will maintain the binary search tree properties. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ROTATE_LEFT' +PP_THREAD_SAFE FUNCTION ROTATE_LEFT( ROOT, X_, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), TARGET, INTENT(INOUT) :: X_ + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + LOGICAL :: IS_ROOT + TYPE(REPRES_NODE_T), POINTER :: X + TYPE(REPRES_NODE_T), POINTER :: Y + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Local variables initialization + X => X_ + Y => NULL() + + ! Rotate. + Y => X%RIGHT + X%RIGHT => Y%LEFT + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + Y%LEFT%PARENT => X + + ENDIF + + Y%PARENT => X%PARENT + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X%PARENT, IS_ROOT, HOOKS ) + IF ( IS_ROOT ) THEN + + ROOT => Y + + ELSE + + IF ( ASSOCIATED( X, X%PARENT%LEFT ) ) THEN + + X%PARENT%LEFT => Y + + ELSE + + X%PARENT%RIGHT => Y + + ENDIF + + ENDIF + + Y%LEFT => X + + X%PARENT => Y + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ROTATE_LEFT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Performs a right rotation on a binary search tree. +!> +!> This subroutine performs a right rotation operation on a binary search tree. +!> It adjusts the structure of the tree to maintain the properties of the binary search tree. +!> +!> @param [inout] ROOT Pointer to the root node of the binary search tree. +!> The tree structure might be modified during the rotation process. +!> @param [inout] X_ Pointer to the node around which the right rotation is performed. +!> +!> @note This subroutine assumes that the binary search tree structure is properly initialized +!> and that the right rotation operation will maintain the binary search tree properties. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'ROTATE_RIGHT' +PP_THREAD_SAFE FUNCTION ROTATE_RIGHT( ROOT, X_, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T),POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), TARGET, INTENT(INOUT) :: X_ + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + LOGICAL :: IS_ROOT_LEAF + TYPE(REPRES_NODE_T), POINTER :: X + TYPE(REPRES_NODE_T), POINTER :: Y + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Local variables initialization + X => X_ + Y => NULL() + + ! Rotate. + Y => X%LEFT + X%LEFT => Y%RIGHT + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + Y%RIGHT%PARENT => X + + ENDIF + + Y%PARENT => X%PARENT + + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X%PARENT, IS_ROOT_LEAF, HOOKS ) + IF ( IS_ROOT_LEAF ) THEN + + ROOT => Y + + ELSE + + IF ( ASSOCIATED( X, X%PARENT%RIGHT ) ) THEN + + X%PARENT%RIGHT => Y + + ELSE + + X%PARENT%LEFT => Y + + ENDIF + + ENDIF + + Y%RIGHT => X + + X%PARENT => Y + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION ROTATE_RIGHT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Checks if a node is a leaf node. +!> +!> This function checks if the specified node is a leaf node in the map structure. +!> A leaf node is a node with no children. +!> +!> @param X Pointer to the node to be checked. +!> +!> @return Logical result indicating whether the node is a leaf (TRUE) or not (FALSE). +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'NODE_ISLEAF' +PP_THREAD_SAFE FUNCTION NODE_ISLEAF( X, ISLEAF, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: X + LOGICAL, INTENT(OUT) :: ISLEAF + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ISLEAF = ASSOCIATED(X, NIL) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +END FUNCTION NODE_ISLEAF +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Finds the successor node in a binary search tree. +!> +!> This function finds the successor node of the specified node in a binary search tree. +!> The successor of a node is the node with the smallest key greater than the key of the specified node. +!> +!> @param [in] X Pointer to the node for which the successor is to be found. +!> @param [out] ERR Output parameter indicating the error status of the operation. +!> A non-zero value indicates an error occurred during the successor search process. +!> +!> @return Pointer to the successor node, if found. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SUCCESSOR' +PP_THREAD_SAFE FUNCTION SUCCESSOR( X, Y, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: X + TYPE(REPRES_NODE_T), POINTER, INTENT(OUT) :: Y + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + TYPE(REPRES_NODE_T), POINTER :: X_ + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NODE_IS_LEAF=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_MINIMUM=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialisation. + X_ => X + Y => NULL() + + ! Check. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X, IS_LEAF, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( IS_LEAF, ERRFLAG_NODE_IS_LEAF ) + + ! Search cycle. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + ! If the node has a right child then the successor is the + ! minimum of the right subtree of the node. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_MINIMUM) MINIMUM( X%RIGHT, Y, HOOKS ) + + ELSE + + ! If the node has not right child, then the successor is the + ! nearest parent node whose left child is a parent of the + ! node. + Y => X%PARENT + + SearchSuccessor: DO + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF .AND. ASSOCIATED( X_, Y%RIGHT ) ) THEN + + X_ => Y + + Y => Y%PARENT + + ELSE + + EXIT SearchSuccessor + + ENDIF + + ENDDO SearchSuccessor + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_NODE_IS_LEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'node is leaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_MINIMUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call minimum' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION SUCCESSOR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Finds the predecessor node in a binary search tree. +!> +!> This function finds the predecessor node of the specified node in a binary search tree. +!> The predecessor of a node is the node with the smallest key greater than the key of the specified node. +!> +!> @param [in] X Pointer to the node for which the predecessor is to be found. +!> @param [out] ERR Output parameter indicating the error status of the operation. +!> A non-zero value indicates an error occurred during the predecessor search process. +!> +!> @return Pointer to the predecessor node, if found. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'PREDECESSOR' +PP_THREAD_SAFE FUNCTION PREDECESSOR( X, Y, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: X + TYPE(REPRES_NODE_T), POINTER, INTENT(OUT) :: Y + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + TYPE(REPRES_NODE_T), POINTER :: X_ + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NODE_IS_LEAF=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_MAXIMUM=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialisation. + X_ => X + Y => NULL() + + ! Check. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X, IS_LEAF, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( IS_LEAF, ERRFLAG_NODE_IS_LEAF ) + + ! Search cycle. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + ! If the node has a left child then the successor is the + ! minimum of the left subtree of the node. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_MAXIMUM) MAXIMUM( X%LEFT, Y, HOOKS ) + + ELSE + + ! If the node has not left child, then the predecessor is the + ! nearest parent node whose right child is a parent of the + ! node. + Y => X%PARENT + + SearchPredecessor: DO + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF .AND. ASSOCIATED( X_, Y%LEFT ) ) THEN + + X_ => Y + + Y => Y%PARENT + + ELSE + + EXIT SearchPredecessor + + ENDIF + + ENDDO SearchPredecessor + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_NODE_IS_LEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'node is leaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_MAXIMUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call maximum' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION PREDECESSOR +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> @brief Finds the minimum key node in a binary search tree. +!> +!> This function finds the node with the minimum key value in a binary search tree +!> rooted at the specified node `X`. +!> +!> @param [in] X Pointer to the root node of the binary search tree. +!> The minimum key node will be searched within the subtree rooted at this node. +!> +!> @return Pointer to the node with the minimum key value, if found. +!> +!> @note This function assumes that the binary search tree structure is properly initialized +!> and that the minimum key node can be found within the subtree rooted at the specified node `X`. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'MINIMUM' +PP_THREAD_SAFE FUNCTION MINIMUM( X, Y, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: X + TYPE(REPRES_NODE_T), POINTER, INTENT(OUT) :: Y + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + + !> Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + !> Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + !> Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + !> Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + !> Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + !> Initialization. + Y => X + + ! Search cycle. + SearchMinimum: DO WHILE(.TRUE.) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + Y => Y%LEFT + + ELSE + + EXIT SearchMinimum + + ENDIF + + ENDDO SearchMinimum + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION MINIMUM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> @brief Finds the maximum key node in a binary search tree. +!> +!> This function finds the node with the maximum key value in a binary search tree +!> rooted at the specified node `X`. +!> +!> @param [in] X Pointer to the root node of the binary search tree. +!> The maximum key node will be searched within the subtree rooted at this node. +!> +!> @return Pointer to the node with the maximum key value, if found. +!> +!> @note This function assumes that the binary search tree structure is properly initialized +!> and that the maximum key node can be found within the subtree rooted at the specified node `X`. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'MAXIMUM' +PP_THREAD_SAFE FUNCTION MAXIMUM( X, Y, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: CACHE_UTILS_MOD, ONLY: CACHE_OPTIONS_T + + !> Templated use + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: X + TYPE(REPRES_NODE_T), POINTER, INTENT(OUT) :: Y + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + + !> Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + !> Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + !> Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + !> Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + !> Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialization. + Y => X + + ! Search cycle. + SearchMaximum: DO WHILE(.TRUE.) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + Y => Y%RIGHT + + ELSE + + EXIT SearchMaximum + + ENDIF + + ENDDO SearchMaximum + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION MAXIMUM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Swaps the data of two map nodes. +!> +!> This subroutine swaps the data (key and value) of two map nodes. +!> It exchanges the content of the nodes without modifying the tree structure. +!> +!> @param NODE_1 Pointer to the first map node whose data is to be swapped. +!> @param NODE_2 Pointer to the second map node whose data is to be swapped. +!> +!> @note This subroutine assumes that both `NODE_1` and `NODE_2` are valid pointers to map nodes. +!> It is the responsibility of the caller to ensure proper initialization of the nodes. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SWAP_DATA' +PP_THREAD_SAFE FUNCTION SWAP_DATA( NODE_1, NODE_2, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: NODE_1 + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: NODE_2 + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: TO_BE_DEALLOCATED + CHARACTER(LEN=REPRES_KEY_LENGTH) :: KEY + CLASS(REPRES_A), POINTER :: REPRES + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SWAP_KEYS=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_SWAP_VALUES=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Swapping keys between two nodes + KEY = NODE_1%KEY + TO_BE_DEALLOCATED = NODE_1%TO_BE_DEALLOCATED + NODE_1%KEY = NODE_2%KEY + NODE_1%TO_BE_DEALLOCATED = NODE_2%TO_BE_DEALLOCATED + NODE_2%KEY = KEY + NODE_2%TO_BE_DEALLOCATED = TO_BE_DEALLOCATED + KEY = REPEAT(' ',REPRES_KEY_LENGTH) + + ! Swapping values between two nodes + REPRES => NODE_1%REPRES_ + NODE_1%REPRES_ => NODE_2%REPRES_ + NODE_2%REPRES_ => REPRES + REPRES => NULL() + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_SWAP_KEYS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to swap keys' ) + CASE (ERRFLAG_SWAP_VALUES) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to swap values' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION SWAP_DATA +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Removes a node from a binary search tree. +!> +!> This subroutine removes a specified node from a binary search tree. +!> It adjusts the tree structure accordingly to maintain the properties of a binary search tree. +!> +!> @param [inout] ROOT Pointer to the root node of the binary search tree. +!> The tree structure might be modified during the removal process. +!> @param [inout] Z Pointer to the node to be removed from the binary search tree. +!> @param [out] ERR Output parameter indicating the error status of the operation. +!> A non-zero value indicates an error occurred during the removal process. +!> +!> @note This subroutine assumes that the binary search tree structure is properly initialized +!> and that the node to be removed is present in the tree. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REMOVE_NODE' +PP_THREAD_SAFE FUNCTION REMOVE_NODE( ROOT, Z, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: Z + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + LOGICAL :: IS_LEAF_LEFT + LOGICAL :: IS_LEAF_RIGHT + TYPE(REPRES_NODE_T), POINTER :: Y + TYPE(REPRES_NODE_T), POINTER :: X + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_SUCESSOR=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_REMOVE_FIXUP=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_DEALLOCATE_NODE=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_SWAP_DATA=5_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialization. + X => NULL() + Y => NULL() + + ! Remove the node + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%LEFT, IS_LEAF_LEFT, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%RIGHT, IS_LEAF_RIGHT, HOOKS ) + IF ( IS_LEAF_LEFT .OR. IS_LEAF_RIGHT ) THEN + + Y => Z + + ELSE + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_SUCESSOR) SUCCESSOR( Z, Y, HOOKS ) + + ENDIF + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + X => Y%LEFT + + ELSE + + X => Y%RIGHT + + ENDIF + + ! Set the X parent, in the case of RED_BLACK_BALANCING the + ! assignment is unconditioned else the assignment will be done + ! only if X .NE. NIL + IF ( RED_BLACK_BALANCING ) THEN + + X%PARENT => Y%PARENT + + ELSE + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( X, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + X%PARENT => Y%PARENT + + ENDIF + + ENDIF + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( Y%PARENT, IS_LEAF, HOOKS ) + IF ( IS_LEAF ) THEN + + ROOT => X + + ELSE + + IF ( ASSOCIATED( Y, Y%PARENT%LEFT) ) THEN + + Y%PARENT%LEFT => X + + ELSE + + Y%PARENT%RIGHT => X + + ENDIF + + ENDIF + + ! If the node to be deleted and the node removed from the + ! list aren't the some node, then copy the data contained in + ! in and trash the old data. + IF ( .NOT.ASSOCIATED( Z, Y ) ) THEN + + ! Copy data. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_SWAP_DATA) SWAP_DATA( Y, Z, HOOKS ) + + ENDIF + + ! Adjust colors of the map. + IF ( RED_BLACK_BALANCING ) THEN + + IF ( .NOT.Y%RED ) THEN + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_REMOVE_FIXUP) REMOVE_NODE_FIXUP( ROOT, X, HOOKS ) + + ENDIF + + ENDIF + + ! Free memory. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_DEALLOCATE_NODE) DEALLOCATE_NODE( Y, HOOKS ) + Y => NULL() + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_SUCESSOR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call successor' ) + CASE (ERRFLAG_UNABLE_TO_CALL_REMOVE_FIXUP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call remove fixup' ) + CASE (ERRFLAG_UNABLE_TO_CALL_DEALLOCATE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call deallocate node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_SWAP_DATA) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call swap data' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REMOVE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Restores Red-Black properties after node removal. +!> +!> This subroutine performs fix-up operations to restore the Red-Black properties +!> of the map structure after a node removal. +!> +!> @param [inout] ROOT Pointer to the root node of the map structure. +!> The map structure might be modified during the fix-up process. +!> @param [inout] X Pointer to the current node that requires fix-up operations. +!> @param [out] ERR Output parameter indicating the error status of the operation. +!> A non-zero value indicates an error occurred during the fix-up process. +!> +!> @note This subroutine assumes that the map structure is a Red-Black tree +!> and that the node removal has potentially violated its properties. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REMOVE_NODE_FIXUP' +PP_THREAD_SAFE FUNCTION REMOVE_NODE_FIXUP( ROOT, X, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: ROOT + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: X + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + TYPE(REPRES_NODE_T), POINTER :: W + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NODE_IS_LEAF=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ROTATE_LEFT=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ROTATE_RIGHT=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialization. + W=>NULL() + + ! Color fix-up cycle. + ColorFixupLoop: DO WHILE( .NOT.ASSOCIATED( X, ROOT ) .AND. .NOT.X%RED ) + + IF ( ASSOCIATED( X, X%PARENT%LEFT ) ) THEN + + W => X%PARENT%RIGHT + + IF ( W%RED ) THEN + + W%RED = .FALSE. + + X%PARENT%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_LEFT) ROTATE_LEFT(ROOT, X%PARENT, HOOKS ) + + W => X%PARENT%RIGHT + + ENDIF + + ! Check if current node is a leaf + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( W, IS_LEAF, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( IS_LEAF, ERRFLAG_NODE_IS_LEAF ) + + IF ( ( .NOT.W%LEFT%RED ) .AND. ( .NOT.W%RIGHT%RED ) ) THEN + W%RED = .TRUE. + + X => X%PARENT + + ELSE + + IF ( .NOT.W%RIGHT%RED ) THEN ! CASO 3 + + W%LEFT%RED = .FALSE. + + W%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_RIGHT) ROTATE_RIGHT(ROOT, W, HOOKS ) + + W => X%PARENT%RIGHT + + ENDIF + + W%RED = X%PARENT%RED + + X%PARENT%RED = .FALSE. + + W%RIGHT%RED = .FALSE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_LEFT) ROTATE_LEFT(ROOT, X%PARENT, HOOKS ) + + X => ROOT + + ENDIF + + ELSE ! Right child + + W => X%PARENT%LEFT + + IF ( W%RED ) THEN + + W%RED = .FALSE. + + X%PARENT%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_RIGHT) ROTATE_RIGHT(ROOT, X%PARENT, HOOKS ) + + W => X%PARENT%LEFT + + ENDIF + + ! Check if current node is a leaf + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( W, IS_LEAF, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( IS_LEAF, ERRFLAG_NODE_IS_LEAF ) + + IF ( .NOT.W%RIGHT%RED .AND. .NOT.W%LEFT%RED ) THEN + + W%RED = .TRUE. + + X => X%PARENT + + ELSE + + IF ( .NOT.W%LEFT%RED ) THEN + + W%RIGHT%RED = .FALSE. + + W%RED = .TRUE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_LEFT) ROTATE_LEFT( ROOT, W, HOOKS ) + + W => X%PARENT%LEFT + + ENDIF + + W%RED = X%PARENT%RED + + X%PARENT%RED = .FALSE. + + W%LEFT%RED = .FALSE. + + PP_TRYCALL(ERRFLAG_UNABLE_TO_ROTATE_RIGHT) ROTATE_RIGHT( ROOT, X%PARENT, HOOKS ) + + X => ROOT + + ENDIF + + ENDIF + + ENDDO ColorFixupLoop + + ! Change color to the node + X%RED = .FALSE. + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_NODE_IS_LEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'node is leaf' ) + CASE (ERRFLAG_UNABLE_TO_ROTATE_LEFT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to rotate left' ) + CASE (ERRFLAG_UNABLE_TO_ROTATE_RIGHT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to rotate right' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REMOVE_NODE_FIXUP +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + + + + +!> @brief Prints all keys in the subtree pointed to by the current node. +!> +!> This subroutine recursively prints all keys in the subtree pointed to by the current node. +!> +!> @param [in] ROOT Pointer to the root node of the subtree. +!> @param [in] CURRENT Pointer to the current node in the subtree. +!> @param [in] UNIT Unit number of the output file where keys will be printed. +!> +!> @note This subroutine assumes that the subtree pointed to by the current node is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'LIST_NODE' +RECURSIVE FUNCTION LIST_NODE( ROOT, CURRENT, CNT, UNIT, PREFIX, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: ROOT + TYPE(REPRES_NODE_T), POINTER, INTENT(IN) :: CURRENT + INTEGER(KIND=JPIB_K), INTENT(INOUT) :: CNT + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + CHARACTER(LEN=*), INTENT(IN) :: PREFIX + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=128) :: CKEY + CHARACTER(LEN=128) :: CCNT + LOGICAL :: IS_LEAF + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_LEFT_SUBTREE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_RIGHT_SUBTREE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! First node in the list. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( CURRENT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_LEFT_SUBTREE) LIST_NODE( ROOT, CURRENT%LEFT, CNT, UNIT, PREFIX, HOOKS ) + + CNT = CNT + 1 + WRITE(CKEY,*,IOSTAT=WRITE_STATUS) CURRENT%KEY + WRITE(CCNT,*,IOSTAT=WRITE_STATUS) CNT + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + + WRITE(UNIT,'(A,A,A,A,A)',IOSTAT=WRITE_STATUS) TRIM(ADJUSTL(PREFIX)), '(', TRIM(ADJUSTL(CCNT)), ') = ', TRIM(ADJUSTL(CKEY)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_RIGHT_SUBTREE) LIST_NODE( ROOT, CURRENT%RIGHT, CNT, UNIT, PREFIX, HOOKS ) + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_LEFT_SUBTREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call left subtree' ) + CASE (ERRFLAG_UNABLE_TO_CALL_RIGHT_SUBTREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call right subtree' ) + CASE (ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'write error' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION LIST_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Renumber nodes in a Red Black tree. +!> +!> This subroutine recursively renumbers nodes in a Red Black tree rooted at the specified node. +!> +!> @param [inout] ROOT The root node of the Red Black tree. +!> @param [inout] IDX The index used for renumbering nodes. +!> +!> @note This subroutine assumes that the Red Black tree structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'RENUMBER_NODE' +RECURSIVE FUNCTION RENUMBER_NODE( ROOT, IDX, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), INTENT(INOUT) :: ROOT + INTEGER(KIND=JPIB_K), INTENT(INOUT) :: IDX + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: IS_LEAF + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Renumber left subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT. IS_LEAF ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE) RENUMBER_NODE( ROOT%LEFT, IDX, HOOKS ) + ENDIF + + ! Renumber right subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT. IS_LEAF ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE) RENUMBER_NODE( ROOT%RIGHT, IDX, HOOKS ) + ENDIF + + ! Renumber the current node + IDX = IDX + 1 + ROOT%IDX = IDX + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call renumber node' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION RENUMBER_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Renumber writes node connectivity in a Red Black tree. +!> +!> This subroutine recursively writes node connectivity in a Red Black tree rooted at the specified node. +!> +!> @param [inout] ROOT The root node of the Red Black tree. +!> @param [inout] UNIT Unit number of the output file where keys will be printed. +!> +!> @note This subroutine assumes that the Red Black tree structure is properly initialized. +!> @note Connectivity is written in the dot format to be parsed with graphviz +!> +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'NODE_WRITE_CONNECTIVITY' +RECURSIVE FUNCTION NODE_WRITE_CONNECTIVITY( ROOT, UNIT, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), INTENT(INOUT) :: ROOT + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Write connectivity of the left subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY) NODE_WRITE_CONNECTIVITY( ROOT%LEFT, UNIT, HOOKS ) + ENDIF + + ! Write connectivity of the right subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT.IS_LEAF ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY) NODE_WRITE_CONNECTIVITY( ROOT%RIGHT, UNIT, HOOKS ) + ENDIF + + ! Write connectivity of the current node + IF ( ASSOCIATED(ROOT%PARENT) ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%PARENT, IS_LEAF, HOOKS ) + IF ( .NOT. IS_LEAF ) THEN + WRITE(UNIT,'(I6.6,A,I6.6)',IOSTAT=WRITE_STATUS) ROOT%PARENT%IDX, '->', ROOT%IDX + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call write connectivity' ) + CASE (ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'write error' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION NODE_WRITE_CONNECTIVITY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Renumber writes nodes in a Red Black tree. +!> +!> This subroutine recursively writes nodes in a Red Black tree rooted at the specified node. +!> +!> @param [inout] ROOT The root node of the Red Black tree. +!> @param [inout] UNIT Unit number of the output file where keys will be printed. +!> +!> @note This subroutine assumes that the Red Black tree structure is properly initialized. +!> @note Nodes are written in the dot format to be parsed with graphviz +!> +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'WRITE_NODE' +RECURSIVE FUNCTION WRITE_NODE( ROOT, UNIT, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_NODE_T), INTENT(INOUT) :: ROOT + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: IS_LEAF + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + CHARACTER(LEN=128) :: CKEY + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_WRITE_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Write nodes in the left subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%LEFT, IS_LEAF, HOOKS ) + IF ( .NOT. ASSOCIATED( ROOT%LEFT, NIL ) ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_NODE) WRITE_NODE( ROOT%LEFT, UNIT, HOOKS ) + ENDIF + + ! Write nodes in the right subtree + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( ROOT%RIGHT, IS_LEAF, HOOKS ) + IF ( .NOT. ASSOCIATED( ROOT%RIGHT, NIL ) ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_NODE) WRITE_NODE( ROOT%RIGHT, UNIT, HOOKS ) + ENDIF + + ! Write the current key + CKEY = REPEAT( ' ', 128 ) + WRITE(CKEY,*,IOSTAT=WRITE_STATUS) ROOT%KEY + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + + ! Write the current node + IF ( ROOT%RED ) THEN + WRITE(UNIT,'(I6.6,A,I8.8,A)', IOSTAT=WRITE_STATUS) ROOT%IDX, ' [ label="', TRIM(ADJUSTL(CKEY)) ,'", fillcolor=red]' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + ELSE + WRITE(UNIT,'(I6.6,A,I8.8,A)', IOSTAT=WRITE_STATUS) ROOT%IDX, ' [ label="', TRIM(ADJUSTL(CKEY)) ,'", fillcolor=black]' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_WRITE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map write node' ) + CASE (ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'write error' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION WRITE_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + +#define PP_PROCEDURE_TYPE 'RECURSIVE FUNCTION' +#define PP_PROCEDURE_NAME 'GET_SORTED_KEYS_INT_NODE' +RECURSIVE FUNCTION GET_SORTED_KEYS_NODE( NODE, SORTED_KEYS, CNT, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(REPRES_NODE_T), POINTER, INTENT(INOUT) :: NODE + CHARACTER(LEN=REPRES_KEY_LENGTH), DIMENSION(:), INTENT(INOUT) :: SORTED_KEYS + INTEGER(KIND=JPIB_K), INTENT(INOUT) :: CNT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: Y + TYPE(REPRES_NODE_T), POINTER :: PREV + LOGICAL :: IS_LEAF + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Remove the map if it is not empty. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( NODE, IS_LEAF, HOOKS ) + IF ( .NOT. IS_LEAF ) THEN + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE) GET_SORTED_KEYS_NODE( NODE%LEFT, SORTED_KEYS, CNT, HOOKS ) + + CNT = CNT + 1 + PP_DEBUG_CRITICAL_COND_THROW( CNT.GT.SIZE(SORTED_KEYS), ERRFLAG_OUT_OF_BOUNDS ) + SORTED_KEYS(CNT) = NODE%KEY + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE) GET_SORTED_KEYS_NODE( NODE%RIGHT, SORTED_KEYS, CNT, HOOKS ) + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map get sorted keys node' ) + CASE (ERRFLAG_OUT_OF_BOUNDS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'out of bounds' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION GET_SORTED_KEYS_NODE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + +!> +!> @brief Initializes a map structure. +!> +!> This subroutine initializes the given map structure. +!> It sets up the necessary components to prepare the map for use. +!> +!> @param [inout] ENCODERS_MAP The map structure to be initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_INIT' +PP_THREAD_SAFE FUNCTION REPRES_INIT( ENCODERS_MAP, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: ENCODERS_MAP + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Map initialization. + ENCODERS_MAP%ROOT => NIL + ENCODERS_MAP%SIZE = 0 + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +END FUNCTION REPRES_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Finalisation of a map structure. +!> +!> This subroutine finalises the given map structure. +!> +!> @param [inout] ENCODERS_MAP The map structure to be finalised. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_FREE' +PP_THREAD_SAFE FUNCTION REPRES_FREE( ENCODERS_MAP, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: ENCODERS_MAP + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_FREE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_INIT=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Remove the map if it is not empty. + IF ( ENCODERS_MAP%SIZE .GT. 0 ) THEN + + ! Recursive deletion of the tree. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_FREE) FREE_NODE( ENCODERS_MAP%ROOT, HOOKS ) + + ENDIF + + ! Reset the initial condition. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_INIT) ENCODERS_MAP%INIT( HOOKS ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map free' ) + CASE (ERRFLAG_UNABLE_TO_CALL_INIT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map init' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Get the minimum value in the map. +!> +!> This subroutine finalises the given map structure. +!> +!> @param [inout] ENCODERS_MAP The map structure to be finalised. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_MINIMUM' +PP_THREAD_SAFE FUNCTION REPRES_MINIMUM( ENCODERS_MAP, KEY, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: ENCODERS_MAP + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(OUT) :: KEY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: Y + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_MINIMUM=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Remove the map if it is not empty. + IF ( ENCODERS_MAP%SIZE .GT. 0 ) THEN + + ! Recursive deletion of the tree. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_MINIMUM) MINIMUM( ENCODERS_MAP%ROOT, Y, HOOKS ) + + KEY = Y%KEY + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_MINIMUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call minimum' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_MINIMUM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Get the maximum value of the map. +!> +!> This subroutine finalises the given map structure. +!> +!> @param [inout] ENCODERS_MAP The map structure to be finalised. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_MAXIMUM' +PP_THREAD_SAFE FUNCTION REPRES_MAXIMUM( ENCODERS_MAP, KEY, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: CACHE_UTILS_MOD, ONLY: CACHE_OPTIONS_T + USE :: MAPPING_OPTIONS_MOD, ONLY: MAPPING_OPTIONS_T + + !> Templated use + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: ENCODERS_MAP + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(OUT) :: KEY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: Y + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_MINIMUM=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Remove the map if it is not empty. + IF ( ENCODERS_MAP%SIZE .GT. 0 ) THEN + + ! Recursive deletion of the tree. + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_MINIMUM) MAXIMUM( ENCODERS_MAP%ROOT, Y, HOOKS ) + + KEY = Y%KEY + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_MINIMUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call maximum' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_MAXIMUM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Get the maximum value of the map. +!> +!> This subroutine finalises the given map structure. +!> +!> @param [inout] ENCODERS_MAP The map structure to be finalised. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET_SORTED_KEYS' +PP_THREAD_SAFE FUNCTION REPRES_GET_SORTED_KEYS( ENCODERS_MAP, SORTED_KEYS, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: ENCODERS_MAP + CHARACTER(LEN=REPRES_KEY_LENGTH), DIMENSION(:), INTENT(INOUT) :: SORTED_KEYS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + INTEGER(KIND=JPIB_K) :: CNT + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_INITIALIZED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRONG_SIZE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE=3_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handing + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ASSOCIATED(ENCODERS_MAP%ROOT), ERRFLAG_NOT_INITIALIZED ) + PP_DEBUG_CRITICAL_COND_THROW( ENCODERS_MAP%SIZE .NE. SIZE(SORTED_KEYS), ERRFLAG_WRONG_SIZE ) + + ! Remove the map if it is not empty. + IF ( ENCODERS_MAP%SIZE .GT. 0 ) THEN + + ! Recursive deletion of the tree. + CNT = 0 + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE) GET_SORTED_KEYS_NODE( ENCODERS_MAP%ROOT, SORTED_KEYS, CNT, HOOKS ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_NOT_INITIALIZED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'map not initialized' ) + CASE (ERRFLAG_WRONG_SIZE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'wrong size' ) + CASE (ERRFLAG_UNABLE_TO_CALL_GET_SORTED_KEYS_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map get sorted keys node' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET_SORTED_KEYS +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Inserts a key-value pair into the map. +!> +!> This subroutine inserts a key-value pair into the map structure. +!> +!> @param [inout] THIS The map structure where the key-value pair will be inserted. +!> @param [in] KEY The key to be inserted into the map. +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_PUSH' +PP_THREAD_SAFE FUNCTION REPRES_PUSH( THIS, KEY, REPRES, TO_BE_DEALLOCATED, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + CLASS(REPRES_A), POINTER, INTENT(IN) :: REPRES + LOGICAL, INTENT(IN) :: TO_BE_DEALLOCATED + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: INSERTED + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_INSERT_NODE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Call the routine to insert a node in the map + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_INSERT_NODE) INSERT_NODE( & + THIS%ROOT, KEY, REPRES, TO_BE_DEALLOCATED, INSERTED, HOOKS ) + + ! Update the number of elements in the map + IF ( INSERTED ) THEN + THIS%SIZE = THIS%SIZE + 1 + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_INSERT_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map insert node' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_PUSH +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Search a key into the map. +!> +!> This subroutine searches a key into the map structure. +!> +!> @param [inout] THIS The map structure where the key-value pair will be inserted. +!> @param [in] KEY The key to be inserted into the map. +!> +!> @result True if the key has been found +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_MATCH' +PP_THREAD_SAFE FUNCTION REPRES_MATCH( THIS, KEY, LMATCH, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + LOGICAL, INTENT(OUT) :: LMATCH + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: ROOT_IS_LEAF + TYPE(REPRES_NODE_T), POINTER :: SEARCHED_NODE + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_SEARCH=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( THIS%ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( ROOT_IS_LEAF ) THEN + + LMATCH = .FALSE. + + ELSE + + ! Search the node in the map + SEARCHED_NODE => NIL + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_SEARCH) SEARCH_NODE( THIS%ROOT, SEARCHED_NODE, KEY, LMATCH, HOOKS ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_SEARCH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call search' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_MATCH +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Search a key into the map. +!> +!> This subroutine searches a key into the map structure. +!> +!> @param [inout] THIS The map structure where the key-value pair will be inserted. +!> @param [in] KEY The key to be inserted into the map. +!> +!> @result True if the key has been found +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_GET' +PP_THREAD_SAFE FUNCTION REPRES_GET( THIS, KEY, REPRES, LMATCH, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + CLASS(REPRES_A), POINTER, INTENT(OUT) :: REPRES + LOGICAL, INTENT(OUT) :: LMATCH + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL :: ROOT_IS_LEAF + TYPE(REPRES_NODE_T), POINTER :: SEARCHED_NODE + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_SEARCH=2_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( THIS%ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( ROOT_IS_LEAF ) THEN + + REPRES => NULL() + LMATCH = .FALSE. + + ELSE + + ! Search the node in the map + SEARCHED_NODE => NIL + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_SEARCH) SEARCH_NODE( THIS%ROOT, SEARCHED_NODE, KEY, LMATCH, HOOKS ) + REPRES => SEARCHED_NODE%REPRES_ + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_SEARCH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call search' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_GET +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Removes a key-value pair into the map. +!> +!> This subroutine removes a key-value pair into the map structure. +!> +!> @param [inout] THIS The map structure from where the key-value pair will be removed. +!> @param [in] KEY The key to be removed into the map. +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_REMOVE' +PP_THREAD_SAFE FUNCTION REPRES_REMOVE( THIS, KEY, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=REPRES_KEY_LENGTH), INTENT(IN) :: KEY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + TYPE(REPRES_NODE_T), POINTER :: SEARCHED_NODE + LOGICAL :: ROOT_IS_LEAF + LOGICAL :: LMATCH + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_REMOVE_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MAP_IS_EMPTY=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_SEARCH=4_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( THIS%ROOT, ROOT_IS_LEAF, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( ROOT_IS_LEAF, ERRFLAG_MAP_IS_EMPTY ) + + ! Search the node in the map + SEARCHED_NODE => NIL + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_SEARCH) SEARCH_NODE( THIS%ROOT, SEARCHED_NODE, KEY, LMATCH, HOOKS ) + + !> If node is found then removve it + IF ( LMATCH ) THEN + !> Remove the node from the map + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_REMOVE_NODE) REMOVE_NODE( THIS%ROOT, SEARCHED_NODE, HOOKS ) + THIS%SIZE = THIS%SIZE - 1 + ENDIF + + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_MAP_IS_EMPTY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'map is empty' ) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_REMOVE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map remove node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_SEARCH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map search' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_REMOVE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Lists all keys in the map. +!> +!> This subroutine lists all keys stored in the map structure. +!> +!> @param [inout] THIS The map structure to list the key-value pairs from. +!> @param [in] UNIT Unit number of the output file where keys will be printed. +!> +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_LIST' +PP_THREAD_SAFE FUNCTION REPRES_LIST( THIS, UNIT, PREFIX, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + CHARACTER(LEN=*), INTENT(IN) :: PREFIX + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + INTEGER(KIND=JPIB_K) :: CNT + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_LIST_NODE=1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Call the recursive writing + CNT = 0_JPIB_K + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_LIST_NODE) LIST_NODE( THIS%ROOT, THIS%ROOT, CNT, UNIT, PREFIX, HOOKS ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_CALL_LIST_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map list node' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_LIST +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @briefPrint the map. +!> +!> This subroutine prints the map in dot format. +!> +!> @param [inout] THIS The map structure to list the key-value pairs from. +!> @param [in] NAME Basename of the file where to print the graph. +!> @param [in] IDX Index used to generate the name. +!> +!> @note The final nema will be: `_.dot` +!> @note This subroutine assumes that the map structure is properly initialized. +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REPRES_PRINT' +PP_THREAD_SAFE FUNCTION REPRES_PRINT( THIS, NAME, IDX, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REPRES_MAP_T), INTENT(INOUT) :: THIS + CHARACTER(LEN=*), INTENT(IN) :: NAME + INTEGER(KIND=JPIB_K), INTENT(IN) :: IDX + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + CHARACTER(LEN=128) :: FNAME + INTEGER(KIND=JPIB_K) :: UNIT + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + LOGICAL :: ROOT_IS_LEAF + + ! Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE_FILE=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_ISLEAF=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_WRITE_NODE=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY=5_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + FNAME=REPEAT(' ',128) + WRITE(FNAME,'(A,I8.8,A)',IOSTAT=WRITE_STATUS) TRIM(ADJUSTL(NAME))//'_', IDX, '.dot' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + + UNIT = 0 + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE) RENUMBER_NODE( THIS%ROOT, UNIT, HOOKS ) + UNIT=131 + + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_ISLEAF) NODE_ISLEAF( THIS%ROOT, ROOT_IS_LEAF, HOOKS ) + IF ( .NOT. ROOT_IS_LEAF ) THEN + OPEN(unit=unit, file=TRIM(FNAME), action='write',IOSTAT=WRITE_STATUS ) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) 'digraph RedBlackTree {' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) 'node [shape=circle, style=filled, fontcolor=white, fontsize=12, width=0.5]' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) 'edge [arrowhead=vee]' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '// Nodes' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_NODE) WRITE_NODE( THIS%ROOT, UNIT, HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '// Connectivity' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY) NODE_WRITE_CONNECTIVITY( THIS%ROOT, UNIT, HOOKS ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + WRITE(UNIT,'(A)',IOSTAT=WRITE_STATUS) '}' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + CLOSE( UNIT,IOSTAT=WRITE_STATUS ) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE_FILE ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point on success + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_WRITE_FILE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to write file' ) + CASE (ERRFLAG_UNABLE_TO_CALL_RENUMBER_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map renumber node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_ISLEAF) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call isleaf' ) + CASE (ERRFLAG_UNABLE_TO_CALL_WRITE_NODE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map write node' ) + CASE (ERRFLAG_UNABLE_TO_CALL_WRITE_CONNECTIVITY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to call map write connectivity' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION REPRES_PRINT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +END MODULE REPRES_MAP_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME diff --git a/src/multiom/data-structures/parametrization/representations_mod.F90 b/src/multiom/data-structures/parametrization/representations_mod.F90 new file mode 100644 index 000000000..355cc94f9 --- /dev/null +++ b/src/multiom/data-structures/parametrization/representations_mod.F90 @@ -0,0 +1,437 @@ +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + +! Definition of the module +#define PP_FILE_NAME 'representations_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'REPRESENTATIONS_MOD' +MODULE REPRESENTATIONS_MOD + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + +IMPLICIT NONE + +!> @brief Default visibility of the module +PRIVATE + + +TYPE, ABSTRACT :: REPRES_A + CHARACTER(LEN=32) :: DATA_REPRESENTATION_TYPE=REPEAT(' ',32) + CHARACTER(LEN=32) :: NAME=REPEAT(' ',32) +CONTAINS + PROCEDURE(REPRES_FREE_IF), PASS, PUBLIC, DEFERRED :: FREE +END TYPE + +ABSTRACT INTERFACE +PP_THREAD_SAFE FUNCTION REPRES_FREE_IF( REPRES, HOOKS ) RESULT(RET) + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + IMPORT :: REPRES_A +IMPLICIT NONE + CLASS(REPRES_A), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + INTEGER(KIND=JPIB_K) :: RET +END FUNCTION REPRES_FREE_IF +END INTERFACE + + +TYPE, EXTENDS(REPRES_A) :: REDUCED_GG_T + INTEGER(KIND=JPIB_K) :: TRUNCATE_DEGREES=0_JPIB_K + INTEGER(KIND=JPIB_K) :: NUMBER_OF_POINTS_ALONG_A_MERIDIAN=0_JPIB_K + INTEGER(KIND=JPIB_K) :: NUMBER_OF_PARALLELS_BETWEEN_POLE_AND_EQUATOR=0_JPIB_K + REAL(KIND=JPRD_K) :: LAT_FIRST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LON_FIRST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LAT_LAST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LON_LAST_GP_DEG=0.0_JPRD_K + LOGICAL :: TO_BE_DEALLOCATED=.FALSE. + INTEGER(KIND=JPIB_K), DIMENSION(:), POINTER :: PL => NULL() +CONTAINS + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => REDUCED_GG_FREE +END TYPE + +TYPE, EXTENDS(REPRES_A) :: REGULAR_GG_T + INTEGER(KIND=JPIB_K) :: TRUNCATE_DEGREES=0_JPIB_K + INTEGER(KIND=JPIB_K) :: NUMBER_OF_POINTS_ALONG_A_MERIDIAN=0_JPIB_K + INTEGER(KIND=JPIB_K) :: NUMBER_OF_POINTS_ALONG_A_PARALLEL=0_JPIB_K + INTEGER(KIND=JPIB_K) :: NUMBER_OF_PARALLELS_BETWEEN_POLE_AND_EQUATOR=0_JPIB_K + REAL(KIND=JPRD_K) :: LAT_FIRST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LON_FIRST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LAT_LAST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LON_LAST_GP_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: IDIR_INC=0.0_JPRD_K +CONTAINS + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => REGULAR_GG_FREE +END TYPE + + +TYPE, EXTENDS(REPRES_A) :: SH_T + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_J=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_K=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_M=0_JPIB_K +CONTAINS + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => SH_FREE +END TYPE + +TYPE, EXTENDS(REPRES_A) :: STRETCHED_SH_T + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_J=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_K=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_M=0_JPIB_K + REAL(KIND=JPRD_K) :: STRETCH_FACTOR=0.0_JPRD_K +CONTAINS + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => STRETCHED_SH_FREE +END TYPE + +TYPE, EXTENDS(REPRES_A) :: STRETCHED_ROTATED_SH_T + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_J=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_K=0_JPIB_K + INTEGER(KIND=JPIB_K) :: PENTAGONAL_RESOLUTIONS_PAR_M=0_JPIB_K + REAL(KIND=JPRD_K) :: STRETCH_FACTOR=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LAT_STRET_DEG=0.0_JPRD_K + REAL(KIND=JPRD_K) :: LON_STRET_DEG=0.0_JPRD_K +CONTAINS + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => STRETCHED_ROTATED_SH_FREE +END TYPE + + +!> Whitelist of public symbols +PUBLIC :: REPRES_A + +! Fields defined in IFS +PUBLIC :: REDUCED_GG_T +PUBLIC :: REGULAR_GG_T +PUBLIC :: STRETCHED_ROTATED_SH_T +PUBLIC :: STRETCHED_SH_T +PUBLIC :: SH_T + +CONTAINS + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REDUCED_GG_FREE' +PP_THREAD_SAFE FUNCTION REDUCED_GG_FREE( REPRES, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REDUCED_GG_T), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + ! Error Flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=0_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + IF ( REPRES%TO_BE_DEALLOCATED ) THEN + DEALLOCATE( REPRES%PL, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + NULLIFY( REPRES%PL ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate the pointer' ) + IF (ALLOCATED(ERRMSG)) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + END IF + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION REDUCED_GG_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'REGULAR_GG_FREE' +PP_THREAD_SAFE FUNCTION REGULAR_GG_FREE( REPRES, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(REGULAR_GG_T), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Nothing to be done for now + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +END FUNCTION REGULAR_GG_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SH_FREE' +PP_THREAD_SAFE FUNCTION SH_FREE( REPRES, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(SH_T), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Nothing to be done for now + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +END FUNCTION SH_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STRETCHED_SH_FREE' +PP_THREAD_SAFE FUNCTION STRETCHED_SH_FREE( REPRES, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(STRETCHED_SH_T), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Nothing to be done for now + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +END FUNCTION STRETCHED_SH_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'STRETCHED_ROTATED_SH_FREE' +PP_THREAD_SAFE FUNCTION STRETCHED_ROTATED_SH_FREE( REPRES, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(STRETCHED_ROTATED_SH_T), INTENT(INOUT) :: REPRES + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Nothing to be done for now + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +END FUNCTION STRETCHED_ROTATED_SH_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE REPRESENTATIONS_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME diff --git a/src/multiom/data-structures/parametrization/satellite_par_mod.F90 b/src/multiom/data-structures/parametrization/satellite_par_mod.F90 index 282c543d7..2d95522b3 100644 --- a/src/multiom/data-structures/parametrization/satellite_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/satellite_par_mod.F90 @@ -25,6 +25,7 @@ MODULE SATELLITE_PAR_MOD INTEGER(KIND=JPIB_K) :: SCALED_FACTOR_OF_CENTRAL_VAWENUMBER = UNDEF_PARAM_E INTEGER(KIND=JPIB_K) :: SCALED_VALUE_OF_CENTRAL_VAWENUMBER = UNDEF_PARAM_E CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => SATELLITE_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => SATELLITE_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_SATELLITE_PAR_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => SATELLITE_PAR_FREE @@ -36,6 +37,97 @@ MODULE SATELLITE_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'SATELLITE_PAR_INIT' +PP_THREAD_SAFE FUNCTION SATELLITE_PAR_INIT(SATELLITE_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(SATELLITE_PAR_T), INTENT(INOUT) :: SATELLITE_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + SATELLITE_PAR%SATELLITE_SERIES = UNDEF_PARAM_E + SATELLITE_PAR%SCALED_FACTOR_OF_CENTRAL_VAWENUMBER = UNDEF_PARAM_E + SATELLITE_PAR%SCALED_VALUE_OF_CENTRAL_VAWENUMBER = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION SATELLITE_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'SATELLITE_PAR_FREE' PP_THREAD_SAFE FUNCTION SATELLITE_PAR_FREE(SATELLITE_PAR, HOOKS ) RESULT(RET) diff --git a/src/multiom/data-structures/parametrization/time_par_mod.F90 b/src/multiom/data-structures/parametrization/time_par_mod.F90 index c8bd3360d..d57653bbe 100644 --- a/src/multiom/data-structures/parametrization/time_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/time_par_mod.F90 @@ -26,6 +26,7 @@ MODULE TIME_PAR_MOD INTEGER(KIND=JPIB_K) :: LENGTH_OF_TIME_STEP_IN_SECONDS_=UNDEF_PARAM_E INTEGER(KIND=JPIB_K) :: LENGTH_OF_TIME_RANGE_IN_SECONDS_=UNDEF_PARAM_E CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => TIME_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => TIME_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: SET_INITIAL_STEP => TIME_PAR_SET_INITIAL_STEP PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: SET_LENGTH_OF_TIME_STEP_IN_SECONDS => TIME_PAR_SET_LENGTH_OF_TIME_STEP_IN_SECONDS @@ -44,6 +45,97 @@ MODULE TIME_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'TIME_PAR_INIT' +PP_THREAD_SAFE FUNCTION TIME_PAR_INIT( TIME_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(TIME_PAR_T), INTENT(INOUT) :: TIME_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + TIME_PAR%INITIAL_STEP_ = UNDEF_PARAM_E + TIME_PAR%LENGTH_OF_TIME_STEP_IN_SECONDS_ = UNDEF_PARAM_E + TIME_PAR%LENGTH_OF_TIME_RANGE_IN_SECONDS_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION TIME_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'TIME_PAR_FREE' PP_THREAD_SAFE FUNCTION TIME_PAR_FREE( TIME_PAR, HOOKS ) RESULT(RET) @@ -978,8 +1070,9 @@ PP_THREAD_SAFE FUNCTION WRITE_TIME_PAR_TO_YAML( TIME_PAR, UNIT, OFFSET, HOOKS ) USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: LOG_UTILS_MOD, ONLY: TO_STRING - USE :: LOG_UTILS_MOD, ONLY: MAX_STR_LEN + USE :: LOG_UTILS_MOD, ONLY: TO_STRING + USE :: LOG_UTILS_MOD, ONLY: MAX_STR_LEN + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -993,10 +1086,10 @@ PP_THREAD_SAFE FUNCTION WRITE_TIME_PAR_TO_YAML( TIME_PAR, UNIT, OFFSET, HOOKS ) IMPLICIT NONE !> Dummy arguments - CLASS(TIME_PAR_T), INTENT(INOUT) :: TIME_PAR - INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT - INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CLASS(TIME_PAR_T), INTENT(IN) :: TIME_PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET @@ -1005,6 +1098,7 @@ PP_THREAD_SAFE FUNCTION WRITE_TIME_PAR_TO_YAML( TIME_PAR, UNIT, OFFSET, HOOKS ) CHARACTER(LEN=MAX_STR_LEN) :: CTMP INTEGER(KIND=JPIB_K) :: WRITE_STAT LOGICAL :: IS_OPENED + LOGICAL, DIMENSION(3) :: CONDITIONS !> Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INVALID_OFFSET = 1_JPIB_K @@ -1030,42 +1124,55 @@ PP_THREAD_SAFE FUNCTION WRITE_TIME_PAR_TO_YAML( TIME_PAR, UNIT, OFFSET, HOOKS ) ! Error handling PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) - ! Check if it is possible to write on the provided unit - INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) - ! Write to the unit - WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'time:' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%INITIAL_STEP_, CTMP, HOOKS ) - - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'initial-step: ', TRIM(ADJUSTL(CTMP)), ' # initial step of the simulation (default = 0)' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - - - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%LENGTH_OF_TIME_STEP_IN_SECONDS_, CTMP, HOOKS ) - - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-step-in-seconds: ', TRIM(ADJUSTL(CTMP)), ' # length of an integration step of the numerical solver in seconds (must be present)' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - - - ! convert integer to string - CTMP = REPEAT(' ', MAX_STR_LEN) - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%LENGTH_OF_TIME_RANGE_IN_SECONDS_, CTMP, HOOKS ) - - ! Write to the unit - WRITE( UNIT, '(A,A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-range-in-seconds: ', TRIM(ADJUSTL(CTMP)), ' # length of the time-range in seconds, which is relevant only in case of statistical field (default=0 -> instant)' - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ! Check if the value is valid + CONDITIONS(1) = TIME_PAR%INITIAL_STEP_ .NE. UNDEF_PARAM_E + CONDITIONS(2) = TIME_PAR%LENGTH_OF_TIME_STEP_IN_SECONDS_ .NE. UNDEF_PARAM_E + CONDITIONS(3) = TIME_PAR%LENGTH_OF_TIME_RANGE_IN_SECONDS_ .NE. UNDEF_PARAM_E + + IF ( ANY(CONDITIONS) ) THEN + + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'time:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + IF ( CONDITIONS(1) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%INITIAL_STEP_, CTMP, HOOKS ) + + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'initial-step: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + + IF ( CONDITIONS(2) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%LENGTH_OF_TIME_STEP_IN_SECONDS_, CTMP, HOOKS ) + + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-step-in-seconds: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + + IF ( CONDITIONS(3) ) THEN + ! convert integer to string + CTMP = REPEAT(' ', MAX_STR_LEN) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( TIME_PAR%LENGTH_OF_TIME_RANGE_IN_SECONDS_, CTMP, HOOKS ) + + ! Write to the unit + WRITE( UNIT, '(A,A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'length-of-time-range-in-seconds: ', TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + + ! Add an empty line + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) - ! Add an empty line - WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET) - PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() diff --git a/src/multiom/data-structures/parametrization/wave_par_mod.F90 b/src/multiom/data-structures/parametrization/wave_par_mod.F90 index 46a0e762f..b739456c4 100644 --- a/src/multiom/data-structures/parametrization/wave_par_mod.F90 +++ b/src/multiom/data-structures/parametrization/wave_par_mod.F90 @@ -24,8 +24,10 @@ MODULE WAVE_PAR_MOD REAL(KIND=JPRD_K), POINTER, DIMENSION(:) :: DIRS_ => NULL() REAL(KIND=JPRD_K), POINTER, DIMENSION(:) :: FREQ_ => NULL() CONTAINS + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => WAVE_PAR_INIT PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: COPY_FROM => WAVE_PAR_COPY_FROM PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: READ_FROM_YAML => READ_WAVE_PAR_FROM_YAML + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: WRITE_TO_YAML => WRITE_WAVE_PAR_TO_YAML PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => WAVE_PAR_FREE END TYPE @@ -35,6 +37,118 @@ MODULE WAVE_PAR_MOD CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WAVE_PAR_INIT' +PP_THREAD_SAFE FUNCTION WAVE_PAR_INIT( WAVE_PAR, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(WAVE_PAR_T), INTENT(INOUT) :: WAVE_PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STATUS + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Copy the data + IF ( WAVE_PAR%TO_BE_DEALLOCATED ) THEN + IF ( ASSOCIATED(WAVE_PAR%DIRS_) ) THEN + DEALLOCATE( WAVE_PAR%DIRS_, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + IF ( ASSOCIATED(WAVE_PAR%FREQ_) ) THEN + DEALLOCATE( WAVE_PAR%FREQ_, STAT=DEALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATUS .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + WAVE_PAR%TO_BE_DEALLOCATED = .FALSE. + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) + IF ( ALLOCATED( ERRMSG)) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STATUS ) + ENDIF + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION WAVE_PAR_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'WAVE_PAR_FREE' PP_THREAD_SAFE FUNCTION WAVE_PAR_FREE( WAVE_PAR, HOOKS ) RESULT(RET) @@ -426,6 +540,214 @@ END FUNCTION READ_WAVE_PAR_FROM_YAML #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE + + + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WRITE_WAVE_PAR_TO_YAML' +PP_THREAD_SAFE FUNCTION WRITE_WAVE_PAR_TO_YAML( WAVE_PAR, UNIT, OFFSET, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + USE :: LOG_UTILS_MOD, ONLY: TO_STRING + USE :: LOG_UTILS_MOD, ONLY: MAX_STR_LEN + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(WAVE_PAR_T), INTENT(IN) :: WAVE_PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=MAX_STR_LEN), DIMENSION(:), ALLOCATABLE :: CATMP + INTEGER(KIND=JPIB_K) :: WRITE_STAT + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + INTEGER(KIND=JPIB_K) :: I + LOGICAL :: IS_OPENED + LOGICAL, DIMENSION(2) :: CONDITIONS + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INVALID_OFFSET = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNIT_NOT_OPENED = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_WRITE_ERROR = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_STRING = 5_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( OFFSET.LT.0, ERRFLAG_INVALID_OFFSET ) + + CONDITIONS(1) = ASSOCIATED(WAVE_PAR%DIRS_) + CONDITIONS(2) = ASSOCIATED(WAVE_PAR%FREQ_) + + IF ( ANY(CONDITIONS) ) THEN + + + ! Check if it is possible to write on the provided unit + INQUIRE( UNIT=UNIT, OPENED=IS_OPENED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.IS_OPENED, ERRFLAG_UNIT_NOT_OPENED ) + + ! Write to the unit + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET), 'wave:' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + IF ( CONDITIONS(1) ) THEN + ! convert integer to string + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( WAVE_PAR%DIRS_, CATMP, HOOKS ) + + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'directions: [' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + IF ( ALLOCATED(CATMP) ) THEN + DO I = 1, SIZE(CATMP)-1 + IF ( MOD(I,20) .EQ. 0 ) THEN + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ELSE + WRITE( UNIT, '(A)', ADVANCE='NO', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ENDDO + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(SIZE(CATMP)))) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2)//']' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + DEALLOCATE(CATMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT.NE.0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + ENDIF + + IF ( CONDITIONS(2) ) THEN + ! convert integer to string + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) TO_STRING( WAVE_PAR%FREQ_, CATMP, HOOKS ) + + WRITE( UNIT, '(A,A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2), 'frequencies: [' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + IF ( ALLOCATED(CATMP) ) THEN + DO I = 1, SIZE(CATMP)-1 + IF ( MOD(I,20) .EQ. 0 ) THEN + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', ADVANCE='NO',IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+4) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ELSE + WRITE( UNIT, '(A)', ADVANCE='NO', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(I)))//', ' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + ENDIF + ENDDO + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) TRIM(ADJUSTL(CATMP(SIZE(CATMP)))) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + WRITE( UNIT, '(A)', IOSTAT=WRITE_STAT ) REPEAT(' ', OFFSET+2)//']' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0, ERRFLAG_WRITE_ERROR ) + + DEALLOCATE(CATMP, STAT=DEALLOC_STAT, ERRMSG=ERRMSG) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT.NE.0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ENDIF + ENDIF + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_INVALID_OFFSET) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'invalid offset' ) + CASE(ERRFLAG_UNIT_NOT_OPENED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unit not opened' ) + CASE(ERRFLAG_WRITE_ERROR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'write error' ) + CASE(ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate memory' ) + IF ( ALLOCATED(ERRMSG)) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error message: ' // TRIM(ERRMSG) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + ENDIF + CASE(ERRFLAG_UNABLE_TO_CONVERT_TO_STRING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to convert to string' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION WRITE_WAVE_PAR_TO_YAML +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + END MODULE WAVE_PAR_MOD #undef PP_SECTION_NAME #undef PP_SECTION_TYPE diff --git a/src/multiom/encoding-rules/cached_encoder_collection_mod.F90 b/src/multiom/encoding-rules/cached_encoder_collection_mod.F90 index 4cf09b690..950569a99 100644 --- a/src/multiom/encoding-rules/cached_encoder_collection_mod.F90 +++ b/src/multiom/encoding-rules/cached_encoder_collection_mod.F90 @@ -37,6 +37,7 @@ MODULE CACHED_ENCODER_COLLECTION_MOD PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: BYTESIZE => CACHED_ENCODER_COLLECTION_BYTESIZE PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: DUMP => CACHED_ENCODER_COLLECTION_DUMP PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: ENCODE => CACHED_ENCODER_COLLECTION_ENCODE + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: PRINT => CACHED_ENCODER_COLLECTION_PRINT PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => CACHED_ENCODER_COLLECTION_FREE END TYPE @@ -584,6 +585,140 @@ END FUNCTION CACHED_ENCODER_COLLECTION_DUMP +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CACHED_ENCODER_COLLECTION_PRINT' +PP_THREAD_SAFE FUNCTION CACHED_ENCODER_COLLECTION_PRINT( THIS, ID, & +& MSG, PAR, UNIT, OFFSET, OPT, HOOKS, SEPARATOR ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A + USE :: TIME_UTILS_MOD, ONLY: CURR_TIME_T + USE :: TIME_UTILS_MOD, ONLY: COMPUTE_CURRENT_TIME + USE :: METADATA_FACTORY_MOD, ONLY: MAKE_METADATA + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CACHED_ENCODER_COLLECTION_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: ID + TYPE(FORTRAN_MESSAGE_T), INTENT(IN) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(IN) :: PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(GRIB_ENCODER_OPTIONS_T), INTENT(IN) :: OPT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SEPARATOR + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: TO_BE_ENCODED + TYPE(CURR_TIME_T) :: CURR_TIME + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ENCODERS_NOT_ASSOCIATED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ID_LESS_THAN_ZERO=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ID_GREATER_THAN_SIZE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PRINT=4_JPIB_K + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ASSOCIATED(THIS%ENCODERS_), ERRFLAG_ENCODERS_NOT_ASSOCIATED ) + PP_DEBUG_CRITICAL_COND_THROW( ID .LE. 0, ERRFLAG_ID_LESS_THAN_ZERO ) + PP_DEBUG_CRITICAL_COND_THROW( ID .GT. SIZE(THIS%ENCODERS_), ERRFLAG_ID_GREATER_THAN_SIZE ) + + ! Print the encoder + IF ( PRESENT(SEPARATOR) ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT) THIS%ENCODERS_(ID)%PRINT( MSG, PAR, 6_JPIB_K, 2_JPIB_K, OPT, HOOKS ) + ELSE + PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT) THIS%ENCODERS_(ID)%PRINT( MSG, PAR, 6_JPIB_K, 2_JPIB_K, OPT, HOOKS ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_ENCODERS_NOT_ASSOCIATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Encoders not associated' ) + CASE(ERRFLAG_ID_LESS_THAN_ZERO) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ID less than zero' ) + CASE(ERRFLAG_ID_GREATER_THAN_SIZE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'ID greater than size' ) + CASE(ERRFLAG_UNABLE_TO_PRINT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to print' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + + +END FUNCTION CACHED_ENCODER_COLLECTION_PRINT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'CACHED_ENCODER_COLLECTION_ENCODE' diff --git a/src/multiom/encoding-rules/cached_encoder_mod.F90 b/src/multiom/encoding-rules/cached_encoder_mod.F90 index 198a94dfc..8c4184cc6 100644 --- a/src/multiom/encoding-rules/cached_encoder_mod.F90 +++ b/src/multiom/encoding-rules/cached_encoder_mod.F90 @@ -48,6 +48,7 @@ MODULE CACHED_ENCODER_MOD PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: INIT => CACHED_ENCODER_INIT PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: ENCODE => CACHED_ENCODER_ENCODE PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: DUMP => CACHED_ENCODER_DUMP + PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: PRINT => CACHED_ENCODER_PRINT PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: BYTESIZE => CACHED_ENCODER_BYTESIZE PROCEDURE, PUBLIC, PASS, NON_OVERRIDABLE :: FREE => CACHED_ENCODER_FREE END TYPE @@ -220,6 +221,151 @@ END FUNCTION CACHED_ENCODER_INIT +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'CACHED_ENCODER_PRINT' +PP_THREAD_SAFE FUNCTION CACHED_ENCODER_PRINT( THIS, MSG, PAR, UNIT, OFFSET, OPT, HOOKS, SEPARATOR ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: GRIB_ENCODER_OPTIONS_MOD, ONLY: GRIB_ENCODER_OPTIONS_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A + USE :: TIME_UTILS_MOD, ONLY: CURR_TIME_T + USE :: TIME_UTILS_MOD, ONLY: COMPUTE_CURRENT_TIME + USE :: METADATA_FACTORY_MOD, ONLY: MAKE_METADATA + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(CACHED_ENCODER_T), INTENT(INOUT) :: THIS + TYPE(FORTRAN_MESSAGE_T), INTENT(IN) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(IN) :: PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(GRIB_ENCODER_OPTIONS_T), INTENT(IN) :: OPT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SEPARATOR + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: TO_BE_ENCODED + TYPE(CURR_TIME_T) :: CURR_TIME + INTEGER(KIND=JPIB_K) :: WRITE_STATUS + + !> Local error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ENCODER_NOT_ALLOCATED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PRINT=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DUMP_MSG = 3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DUMP_PAR = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE = 5_JPIB_K + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT. ASSOCIATED(THIS%ENCODER_), ERRFLAG_ENCODER_NOT_ALLOCATED ) + + WRITE(UNIT,*,IOSTAT=WRITE_STATUS) REPEAT(' ',1) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(UNIT,*,IOSTAT=WRITE_STATUS) '** CACHED_ENCODER_T' + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) + + PP_TRYCALL(ERRFLAG_UNABLE_TO_DUMP_MSG) MSG%WRITE_TO_YAML( UNIT, OFFSET, HOOKS ) + WRITE(UNIT,*,IOSTAT=WRITE_STATUS) REPEAT(' ',OFFSET) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STATUS .NE. 0, ERRFLAG_UNABLE_TO_WRITE ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_DUMP_PAR) PAR%WRITE_TO_YAML( UNIT, OFFSET, HOOKS ) + + ! Print the encoder + IF ( PRESENT(SEPARATOR) ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT) THIS%ENCODER_%PRINT( UNIT, OFFSET, OPT, HOOKS, SEPARATOR ) + ELSE + PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT) THIS%ENCODER_%PRINT( UNIT, OFFSET, OPT, HOOKS ) + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_ENCODER_NOT_ALLOCATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'encoder not allocated' ) + CASE(ERRFLAG_UNABLE_TO_PRINT) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error printing encoder' ) + CASE(ERRFLAG_UNABLE_TO_DUMP_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error dumping message' ) + CASE(ERRFLAG_UNABLE_TO_DUMP_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error dumping parameterization' ) + CASE(ERRFLAG_UNABLE_TO_WRITE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'error writing to unit' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + + +END FUNCTION CACHED_ENCODER_PRINT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME ' CACHED_ENCODER_ENCODE' PP_THREAD_SAFE FUNCTION CACHED_ENCODER_ENCODE( THIS, MSG, PAR, TAG, NAME, METADATA, ENCODING_DONE, OPT, HOOKS ) RESULT(RET) diff --git a/src/multiom/ifs-encoders/multiom_cached_encoder_mod.F90 b/src/multiom/ifs-encoders/multiom_cached_encoder_mod.F90 index e85fb1f67..ed1c61a13 100644 --- a/src/multiom/ifs-encoders/multiom_cached_encoder_mod.F90 +++ b/src/multiom/ifs-encoders/multiom_cached_encoder_mod.F90 @@ -209,6 +209,12 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_INIT( THIS, & PP_TRYCALL(ERRFLAG_MAPPING_RULE_DELETE_ERROR) YAML_DELETE_CONFIGURATION( & & MAPPING_CONFIG, HOOKS ) + !> Initialize the mapping cache + PP_TRYCALL(ERRFLAG_MAPPING_CACHE_INIT) THIS%MAPPING_CACHE%INIT( THIS%CACHE_OPTIONS, HOOKS ) + + + PP_TRYCALL(ERRFLAG_ENCODER_CACHE_INIT) THIS%ENCODER_CACHE%INIT( THIS%CACHE_OPTIONS, HOOKS ) + ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -332,6 +338,9 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_ENCODE( THIS, & CHARACTER(LEN=256) :: MAPPING_NAME CHARACTER(LEN=256) :: ENCODER_TAG CHARACTER(LEN=256) :: ENCODER_NAME + CHARACTER(LEN=:), ALLOCATABLE :: JSON + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG !> Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MAPPING_CACHE_INIT = 1_JPIB_K @@ -342,6 +351,9 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_ENCODE( THIS, & INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_ENCODER_COLLECTION_ENCODE = 6_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ADD_METADATA = 7_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_FREE_METADATA_LIST = 8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON = 10_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DUMP_MSG = 11_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -381,6 +393,17 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_ENCODE( THIS, & PP_TRYCALL(ERRFLAG_MAPPING_COLLECTION_EVAL) MAPPER%EVAL( I, & & MSG, PAR, MAPPED_MSG, MAPPED_PAR, MAPPING_TAG, MAPPING_NAME, HOOKS ) + +! !> Print Mapped message +! PP_TRYCALL(ERRFLAG_MARS_TO_JSON) MAPPED_MSG%TO_JSON( JSON, HOOKS ) +! IF ( ALLOCATED(JSON) ) THEN +! WRITE(*,'(A,A)') ' * MAPPED - MARS to JSON: ', JSON +! DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) +! PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) +! ELSE +! WRITE(*,*) ' * MAPPED - MARS to JSON: ', 'NO JSON' +! END IF + !> Encode the message PP_TRYCALL(ERRFLAG_ENCODER_CACHE_INIT) THIS%ENCODER_CACHE%ACCESS_OR_CREATE( & & MAPPED_MSG, MAPPED_PAR, THIS%METADATA, THIS%ENCODER_RULES, ENCODERS, & @@ -396,18 +419,27 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_ENCODE( THIS, & METADATA => NULL() !> Perform the encoding - PP_TRYCALL(ERRFLAG_ENCODER_COLLECTION_ENCODE) ENCODERS%ENCODE( J, & -& MAPPED_MSG, MAPPED_PAR, ENCODER_TAG, ENCODER_NAME, METADATA, ENCODING_DONE, & -& THIS%ENCODER_OPTIONS, HOOKS ) - + PP_TRYCALL(ERRFLAG_ENCODER_COLLECTION_ENCODE) ENCODERS%PRINT( J, & +& MAPPED_MSG, MAPPED_PAR, 6_JPIB_K, 0_JPIB_K, THIS%ENCODER_OPTIONS, HOOKS ) + + ENCODING_DONE = .FALSE. +! !> Perform the encoding +! PP_TRYCALL(ERRFLAG_ENCODER_COLLECTION_ENCODE) ENCODERS%ENCODE( J, & +! & MAPPED_MSG, MAPPED_PAR, ENCODER_TAG, ENCODER_NAME, METADATA, ENCODING_DONE, & +! & THIS%ENCODER_OPTIONS, HOOKS ) +! !> If encdong required/done then add the metadata the the list IF ( ENCODING_DONE ) THEN PP_TRYCALL(ERRFLAG_UNABLE_TO_ADD_METADATA) METADATA_LIST%PUSH( MAPPED_MSG, MAPPED_PAR, & & MAPPING_TAG, MAPPING_NAME, ENCODER_TAG, ENCODER_NAME, METADATA, HOOKS ) ENDIF - ENDDO + + !> Reset mapped message and parameter + PP_TRYCALL(ERRFLAG_FREE_MAPPED_MSG) MAPPED_MSG%FREE( HOOKS ) + PP_TRYCALL(ERRFLAG_FREE_MAPPED_PAR) MAPPED_PAR%FREE( HOOKS ) + ENDDO ! Trace end of procedure (on success) @@ -448,6 +480,10 @@ PP_THREAD_SAFE FUNCTION MULTIO_ENCODER_ENCODE( THIS, & PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to add the metadata to the list' ) CASE (ERRFLAG_FREE_METADATA_LIST) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the metadata list' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate the JSON' ) + CASE (ERRFLAG_MARS_TO_JSON) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert MARS to JSON' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) END SELECT diff --git a/src/multiom/ifs-interface/ifs_msg_mod.F90 b/src/multiom/ifs-interface/ifs_msg_mod.F90 index 0bcaf5a88..e723603af 100644 --- a/src/multiom/ifs-interface/ifs_msg_mod.F90 +++ b/src/multiom/ifs-interface/ifs_msg_mod.F90 @@ -1692,6 +1692,9 @@ PP_THREAD_SAFE FUNCTION PRINT_ATM( DATA, UNIT, HOOKS ) RESULT(RET) ! Trace begin of procedure PP_TRACE_ENTER_PROCEDURE() + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + ! Conversions PP_TRYCALL(ERRFLAG_IPREFIX2ILEVTYPE) IPREFIX2ILEVTYPE( DATA%IPREF_, DATA%PARAM_ID_, DATA%ILEVG_, DATA%IREPRES_, ILEVTYPE, HOOKS ) PP_TRYCALL(ERRFLAG_ILEVTYPE2CLEVTYPE) ILEVTYPE2CLEVTYPE( ILEVTYPE, CLEVTYPE, HOOKS ) diff --git a/src/multiom/ifs-interface/ifs_par_mod.F90 b/src/multiom/ifs-interface/ifs_par_mod.F90 index d19fa48e7..823c152bd 100644 --- a/src/multiom/ifs-interface/ifs_par_mod.F90 +++ b/src/multiom/ifs-interface/ifs_par_mod.F90 @@ -188,7 +188,7 @@ MODULE IFS_PAR_MOD LOGICAL :: LPPSTEPS - REAL(KIND=JPIB_K) :: TSTEP + REAL(KIND=JPRD_K) :: TSTEP ! LOBSC1 : .T. = term of observations included in configuration 1 LOGICAL :: LOBSC1 diff --git a/src/multiom/ifs2mars/ifs2mars_mod.F90 b/src/multiom/ifs2mars/ifs2mars_mod.F90 index 5859b64e5..87565d83b 100644 --- a/src/multiom/ifs2mars/ifs2mars_mod.F90 +++ b/src/multiom/ifs2mars/ifs2mars_mod.F90 @@ -20,11 +20,17 @@ #define PP_SECTION_TYPE 'MODULE' #define PP_SECTION_NAME 'IFS2MARS_MOD' MODULE IFS2MARS_MOD + IMPLICIT NONE ! Default visibility PRIVATE +INTERFACE IFS2MARS_SET_IDENTIFICATION +MODULE PROCEDURE IFS2MARS_SET_IDENTIFICATION_ATM +MODULE PROCEDURE IFS2MARS_SET_IDENTIFICATION_WAM +END INTERFACE + ! Whitelist of public symbols PUBLIC :: IFS2MARS_SET_STREAM ! STREAM PUBLIC :: IFS2MARS_SET_TYPE ! TYPE @@ -38,12 +44,86 @@ MODULE IFS2MARS_MOD PUBLIC :: IFS2MARS_SET_ORIGIN ! ORIGIN PUBLIC :: ATM2MARS_SET_SATELLITE ! IDENT/INSTRUMENT/CHANNEL PUBLIC :: ATM2MARS_SET_PARAM ! PARAM/PARAM_TYPE/CHEM/WAVELENGTH +PUBLIC :: WAM2MARS_SET_PARAM ! PARAM/PARAM_TYPE PUBLIC :: IFS2MARS_SET_DATETIME ! DATE/TIME/STEP/TIMEPROC - -! PUBLIC :: IFS2MARS_SET_GEOMETRY ! GRID/REPRES -! PUBLIC :: IFS2MARS_SET_WAVE ! DIRECTION/FREQUENCY +PUBLIC :: IFS2MARS_SET_GEOMETRY ! GRID/REPRES +PUBLIC :: WAM2MARS_SET_DIRFREQ ! DIRECTION/FREQUENCY +PUBLIC :: IFS2MARS_SET_IDENTIFICATION ! PAR::GENERATING_PROCESS_IDENTIFIER CONTAINS +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WAM2MARS_IS_WAVE_SPECTRA' +PP_THREAD_SAFE FUNCTION WAM2MARS_IS_WAVE_SPECTRA( IFS_MSG, IFS_PAR, IS_WAVE_SPECTRA, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T + USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T + + USE :: GRIB_CODES_MOD, ONLY: NGRBCRRFL + USE :: GRIB_CODES_MOD, ONLY: NGRBCDRFL + USE :: GRIB_CODES_MOD, ONLY: NGRBCSBT + USE :: GRIB_CODES_MOD, ONLY: NGRBCLBT + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(OM_WAM_MSG_T), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + LOGICAL, INTENT(OUT) :: IS_WAVE_SPECTRA + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL, DIMENSION(4) :: CONDITIONS + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Conditions to match the satellite message + CONDITIONS(1) = (IFS_MSG%PARAM_ID_ .EQ. 140250) + CONDITIONS(2) = (IFS_MSG%PARAM_ID_ .EQ. 140251) + + ! If any of the conditions match the it is a satellite message + IF ( ANY(CONDITIONS) ) THEN + IS_WAVE_SPECTRA = .TRUE. + ELSE + IS_WAVE_SPECTRA = .FALSE. + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +END FUNCTION WAM2MARS_IS_WAVE_SPECTRA +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'ATM2MARS_IS_SATELLITE' @@ -1034,7 +1114,7 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_EXPVER( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) PP_SET_ERR_SUCCESS( RET ) ! Set stream - MSG%STREAM = IFS_PAR%SIM_%NSTREAM + MSG%EXPVER = IFS_PAR%SIM_%CNMEXP(1:4) ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1476,8 +1556,8 @@ END FUNCTION IFS2MARS_SET_ENSEMBLE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'ATM2MARS_SET_PARAM' -PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'IFS2MARS_SET_IDENTIFICATION_ATM' +PP_THREAD_SAFE FUNCTION IFS2MARS_SET_IDENTIFICATION_ATM( ATM_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K @@ -1486,10 +1566,7 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T - USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_CHEMICAL_E - USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_OPTICAL_E - USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_CHEMICAL_OPTICAL_E - USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_BASE_E + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1503,7 +1580,7 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG + CLASS(OM_ATM_MSG_T), INTENT(IN) :: ATM_MSG TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR @@ -1527,21 +1604,7 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! Extract paramtype - IF ( IFS_MSG%PARAM_ID_ .GE. 400000000 .AND. IFS_MSG%PARAM_ID_ .LT. 500000000 ) THEN - MSG%PARAM_TYPE = PARAMTYPE_CHEMICAL_OPTICAL_E - MSG%PARAM = IFS_MSG%PARAM_ID_/1000000*1000 - MSG%CHEM = MOD( IFS_MSG%PARAM_ID_/1000, 1000 ) - ! TODO: need to understand how to handle wavelength ranges - ! WAVELENGTH_ID = MOD( IFS_MSG%PARAM_ID_, 1000 ) - ELSEIF ( IFS_MSG%PARAM_ID_ .GE. 400000 .AND. IFS_MSG%PARAM_ID_ .LT. 500000 ) THEN - MSG%PARAM_TYPE = PARAMTYPE_CHEMICAL_E - MSG%PARAM = (IFS_MSG%PARAM_ID_/1000)*1000 - MSG%CHEM = MOD( IFS_MSG%PARAM_ID_, 1000 ) - ELSE - MSG%PARAM_TYPE = PARAMTYPE_BASE_E - MSG%PARAM = IFS_MSG%PARAM_ID_ - ENDIF + PAR%GENERATING_PROCESS_IDENTIFIER = IFS_PAR%SIM_%NCYCLE ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1583,27 +1646,23 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) ! Exit point on error RETURN -END FUNCTION ATM2MARS_SET_PARAM +END FUNCTION IFS2MARS_SET_IDENTIFICATION_ATM #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_SET_DATETIME' -PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'IFS2MARS_SET_IDENTIFICATION_WAM' +PP_THREAD_SAFE FUNCTION IFS2MARS_SET_IDENTIFICATION_WAM( WAM_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T - USE :: DATETIME_UTILS_MOD, ONLY: UNPACK_YYYYMMDD - USE :: DATETIME_UTILS_MOD, ONLY: SEC2HH_MM_SS - USE :: DATETIME_UTILS_MOD, ONLY: PACK_YYYYMMDD - USE :: DATETIME_UTILS_MOD, ONLY: PACK_HHMM - USE :: DATETIME_UTILS_MOD, ONLY: DATE_SUB_DAYS + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1617,7 +1676,7 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS IMPLICIT NONE ! Dummy arguments - CLASS(OM_BASE_MSG_A), INTENT(IN) :: IFS_MSG + CLASS(OM_WAM_MSG_T), INTENT(IN) :: WAM_MSG TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR @@ -1626,32 +1685,6 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET - ! Local variables - LOGICAL, DIMENSION(2) :: CONDITION1 - LOGICAL, DIMENSION(2) :: CONDITION2 - - INTEGER(KIND=JPIB_K) :: DYYYY - INTEGER(KIND=JPIB_K) :: DMM - INTEGER(KIND=JPIB_K) :: DDD - INTEGER(KIND=JPIB_K) :: THH - INTEGER(KIND=JPIB_K) :: TMM - INTEGER(KIND=JPIB_K) :: TSS - INTEGER(KIND=JPIB_K) :: DYYYY1 - INTEGER(KIND=JPIB_K) :: DMM1 - INTEGER(KIND=JPIB_K) :: DDD1 - INTEGER(KIND=JPIB_K) :: THH1 - INTEGER(KIND=JPIB_K) :: TMM1 - INTEGER(KIND=JPIB_K) :: TSS1 - INTEGER(KIND=JPIB_K) :: IFCDA_INI - INTEGER(KIND=JPIB_K) :: IFCHO_RES - - ! Error flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_UNPACK_DATETIME=1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVER_SECONDS=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_DATE=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_TIME=4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SUB_DAYS=5_JPIB_K - ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1667,70 +1700,12 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! Extract date/time components - PP_TRYCALL(ERRFLAG_UNABLE_TO_UNPACK_DATETIME) UNPACK_YYYYMMDD( IFS_PAR%SIM_%NINDAT, DYYYY, DMM, DDD, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVER_SECONDS) SEC2HH_MM_SS( IFS_PAR%SIM_%NSSSSS, THH, TMM, TSS, HOOKS ) - - ! Initialization of the modified date/time - ! NOTE: Apparently minutes and seconds are cut away in the grib encoding, - ! not sure it is the correct way to proceed - DYYYY1 = DYYYY - DMM1 = DMM - DDD1 = DDD - THH1 = THH - TMM1 = 0 - TSS1 = 0 - - ! First special case - CONDITION1(1) = (IFS_PAR%SIM_%CTYPE .EQ. 'fc') ! 'type' is forecast (gribCode=9) - CONDITION1(2) = (IFS_PAR%SIM_%LOBSC1) ! .T. = term of observations included in configuration 1 - - ! Second special case - CONDITION2(1) = (IFS_PAR%SIM_%LVAREPS) ! .T. when running with variable resolution - CONDITION2(2) = (IFS_PAR%SIM_%NLEG .GE. 2) ! current VAREPS leg number (eg 1(2) for the T399(T255) part of a T399-T255 VAREPS) - - - ! If needed modify the time - IF ( ALL(CONDITION1) ) THEN - ! NOTE: This code works because NSTEPINI is supposed to be less than 24 - ! NSTEPINI: Initial step in hours for the initial conditions - ! at the beginning of 4D-Var trajectory (usually 3 hours). - ! It is used to update the step while saving the FCs along - ! the first trajectory. - THH1 = THH - IFS_PAR%SIM_%NSTEPINI - IF ( THH1 .LT. 0 ) THEN - THH1 = THH1 + 24 - ! TODO: Replace custom function with Julian date provided in eccodes - PP_TRYCALL(ERRFLAG_UNABLE_TO_SUB_DAYS) DATE_SUB_DAYS( DYYYY, DMM, DDD, INT(-1,JPIB_K), DYYYY1, DMM1, DDD1, HOOKS ) - ENDIF - - ELSEIF ( ALL(CONDITION2) ) THEN - - ! NFCHO_TRUNC_INI: forecast step used to define the ICs (ie NFCHO_TRUNC of previous VAREPS LEG) - IFCDA_INI = IFS_PAR%SIM_%NFCHO_TRUNC_INI/24 - IFCHO_RES = MOD(IFS_PAR%SIM_%NFCHO_TRUNC_INI, 24) - THH1 = THH - IFCHO_RES - TMM1 = 0 - TSS1 = 0 - IF ( THH1 .LT. 0 ) THEN - THH1 = THH1 + 24 - IFCDA_INI = IFCDA_INI + 1 - ENDIF - ! TODO: Replace custom function with Julian date provided in eccodes - PP_TRYCALL(ERRFLAG_UNABLE_TO_SUB_DAYS) DATE_SUB_DAYS( DYYYY, DMM, DDD, -IFCDA_INI, DYYYY1, DMM1, DDD1, HOOKS ) - + IF ( IFS_PAR%WAM_%CLDOMAIN == 'g' ) THEN + PAR%GENERATING_PROCESS_IDENTIFIER = IFS_PAR%WAM_%IMDLGRBID_G + ELSE + PAR%GENERATING_PROCESS_IDENTIFIER = IFS_PAR%WAM_%IMDLGRBID_M ENDIF - ! Output date and time - PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_DATE) PACK_YYYYMMDD( DYYYY1, DMM1, DDD1, MSG%DATE, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_TIME) PACK_HHMM( THH1, TMM1, MSG%TIME, HOOKS ) - - ! Set the step - MSG%STEP = IFS_MSG%ISTEP_ - - ! Somehow need to set "timeproc" - MSG%TIMEPROC = 'point-in-time' - ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1753,16 +1728,6 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! HAndle different errors SELECT CASE(ERRIDX) - CASE(ERRFLAG_UNABLE_TO_UNPACK_DATETIME) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in unpacking date/time' ) - CASE(ERRFLAG_UNABLE_TO_CONVER_SECONDS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in converting seconds to HH:MM:SS' ) - CASE(ERRFLAG_UNABLE_TO_PACK_DATE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing date' ) - CASE(ERRFLAG_UNABLE_TO_PACK_TIME) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing time' ) - CASE(ERRFLAG_UNABLE_TO_SUB_DAYS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in subtracting days' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -1781,21 +1746,26 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! Exit point on error RETURN -END FUNCTION IFS2MARS_SET_DATETIME +END FUNCTION IFS2MARS_SET_IDENTIFICATION_WAM #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_NEEDS_PV_ARRAY' -PP_THREAD_SAFE FUNCTION IFS2MARS_NEEDS_PV_ARRAY( IFS_MSG, IFS_PAR, NEEDS_PV_ARRAY, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'ATM2MARS_SET_PARAM' +PP_THREAD_SAFE FUNCTION ATM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T - USE :: ENUMERATORS_MOD, ONLY: PREFIX_MODEL_LEVEL_E + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_CHEMICAL_E + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_OPTICAL_E + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_CHEMICAL_OPTICAL_E + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_BASE_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1809,10 +1779,11 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_NEEDS_PV_ARRAY( IFS_MSG, IFS_PAR, NEEDS_PV_ARRA IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - LOGICAL, INTENT(OUT) :: NEEDS_PV_ARRAY - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET @@ -1832,11 +1803,20 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_NEEDS_PV_ARRAY( IFS_MSG, IFS_PAR, NEEDS_PV_ARRA ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! At the moment we need the PV array only for the model levels - IF ( IFS_MSG%IPREF_ .EQ. PREFIX_MODEL_LEVEL_E ) THEN - NEEDS_PV_ARRAY = .TRUE. + ! Extract paramtype + IF ( IFS_MSG%PARAM_ID_ .GE. 400000000 .AND. IFS_MSG%PARAM_ID_ .LT. 500000000 ) THEN + ! MSG%PARAM_TYPE = PARAMTYPE_CHEMICAL_OPTICAL_E + MSG%PARAM = IFS_MSG%PARAM_ID_/1000000*1000 + MSG%CHEM = MOD( IFS_MSG%PARAM_ID_/1000, 1000 ) + ! TODO: need to understand how to handle wavelength ranges + ! WAVELENGTH_ID = MOD( IFS_MSG%PARAM_ID_, 1000 ) + ELSEIF ( IFS_MSG%PARAM_ID_ .GE. 400000 .AND. IFS_MSG%PARAM_ID_ .LT. 500000 ) THEN + ! MSG%PARAM_TYPE = PARAMTYPE_CHEMICAL_E + MSG%PARAM = (IFS_MSG%PARAM_ID_/1000)*1000 + MSG%CHEM = MOD( IFS_MSG%PARAM_ID_, 1000 ) ELSE - NEEDS_PV_ARRAY = .FALSE. + ! MSG%PARAM_TYPE = PARAMTYPE_BASE_E + MSG%PARAM = IFS_MSG%PARAM_ID_ ENDIF ! Trace end of procedure (on success) @@ -1845,40 +1825,83 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_NEEDS_PV_ARRAY( IFS_MSG, IFS_PAR, NEEDS_PV_ARRA ! Exit point (on success) RETURN -END FUNCTION IFS2MARS_NEEDS_PV_ARRAY -#undef PP_PROCEDURE_NAME -#undef PP_PROCEDURE_TYPE - +! Error handler +PP_ERROR_HANDLER -#define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_INFER_GG_REPRES_FROM_IFS' -PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_GG_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAME, HOOKS ) RESULT(RET) + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) - ! Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T - USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T - ! Symbols imported by the preprocessor for debugging purposes - PP_DEBUG_USE_VARS +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) - ! Symbols imported by the preprocessor for logging purposes - PP_LOG_USE_VARS + BLOCK - ! Symbols imported by the preprocessor for tracing purposes - PP_TRACE_USE_VARS + ! Error handling variables + PP_DEBUG_PUSH_FRAME() -IMPLICIT NONE + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION ATM2MARS_SET_PARAM +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WAM2MARS_SET_PARAM' +PP_THREAD_SAFE FUNCTION WAM2MARS_SET_PARAM( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T + USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_WAVE_SPECTRA_E + USE :: ENUMERATORS_MOD, ONLY: PARAMTYPE_BASE_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - CHARACTER(LEN=8), INTENT(OUT) :: NAME - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + TYPE(OM_WAM_MSG_T), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET + ! Local variables + LOGICAL, DIMENSION(2) :: CONDITIONS + ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1894,7 +1917,21 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_GG_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAM ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! TODO + ! Checks + CONDITIONS(1) = IFS_MSG%PARAM_ID_ .EQ. 140250 + CONDITIONS(2) = IFS_MSG%PARAM_ID_ .EQ. 140251 + ! TODO : more conditions to be added + + ! Extract paramtype + IF ( ANY(CONDITIONS) ) THEN + ! MSG%PARAM_TYPE = PARAMTYPE_WAVE_SPECTRA_E + MSG%PARAM = IFS_MSG%PARAM_ID_ + ! TODO: need to understand how to handle wavelength ranges + ! WAVELENGTH_ID = MOD( IFS_MSG%PARAM_ID_, 1000 ) + ELSE + ! MSG%PARAM_TYPE = PARAMTYPE_BASE_E + MSG%PARAM = IFS_MSG%PARAM_ID_ + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1902,20 +1939,61 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_GG_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAM ! Exit point (on success) RETURN -END FUNCTION IFS2MARS_INFER_GG_REPRES_FROM_IFS +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION WAM2MARS_SET_PARAM #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_INFER_SH_REPRES_FROM_IFS' -PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_SH_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAME, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'IFS2MARS_SET_DATETIME' +PP_THREAD_SAFE FUNCTION IFS2MARS_SET_DATETIME( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T + USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: DATETIME_UTILS_MOD, ONLY: UNPACK_YYYYMMDD + USE :: DATETIME_UTILS_MOD, ONLY: SEC2HH_MM_SS + USE :: DATETIME_UTILS_MOD, ONLY: PACK_YYYYMMDD + USE :: DATETIME_UTILS_MOD, ONLY: PACK_HHMMSS + USE :: DATETIME_UTILS_MOD, ONLY: DATE_SUB_DAYS ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1929,14 +2007,48 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_SH_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAM IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - CHARACTER(LEN=8), INTENT(OUT) :: NAME - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CLASS(OM_BASE_MSG_A), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET + ! Local variables + LOGICAL, DIMENSION(2) :: CONDITION1 + LOGICAL, DIMENSION(2) :: CONDITION2 + + INTEGER(KIND=JPIB_K) :: DYYYY + INTEGER(KIND=JPIB_K) :: DMM + INTEGER(KIND=JPIB_K) :: DDD + INTEGER(KIND=JPIB_K) :: THH + INTEGER(KIND=JPIB_K) :: TMM + INTEGER(KIND=JPIB_K) :: TSS + INTEGER(KIND=JPIB_K) :: DYYYY1 + INTEGER(KIND=JPIB_K) :: DMM1 + INTEGER(KIND=JPIB_K) :: DDD1 + INTEGER(KIND=JPIB_K) :: THH1 + INTEGER(KIND=JPIB_K) :: TMM1 + INTEGER(KIND=JPIB_K) :: TSS1 + INTEGER(KIND=JPIB_K) :: IFCDA_INI + INTEGER(KIND=JPIB_K) :: IFCHO_RES + LOGICAL :: IS_ANALYSIS + INTEGER(KIND=JPIB_K) :: DATE + INTEGER(KIND=JPIB_K) :: TIME + INTEGER(KIND=JPIB_K) :: STEP + INTEGER(KIND=JPIB_K) :: TIMESTEP_IN_SECONDS + + ! Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_UNPACK_DATETIME=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVER_SECONDS=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_DATE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_TIME=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SUB_DAYS=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CHECK_TYPE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ANALYSIS=7_JPIB_K + ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1952,29 +2064,164 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_INFER_SH_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, NAM ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! TODO + ! Extract date/time components + PP_TRYCALL(ERRFLAG_UNABLE_TO_UNPACK_DATETIME) UNPACK_YYYYMMDD( IFS_PAR%SIM_%NINDAT, DYYYY, DMM, DDD, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVER_SECONDS) SEC2HH_MM_SS( IFS_PAR%SIM_%NSSSSS, THH, TMM, TSS, HOOKS ) + + ! Initialization of the modified date/time + ! NOTE: Apparently minutes and seconds are cut away in the grib encoding, + ! not sure it is the correct way to proceed + DYYYY1 = DYYYY + DMM1 = DMM + DDD1 = DDD + THH1 = THH + TMM1 = 0 + TSS1 = 0 + + ! First special case + CONDITION1(1) = (IFS_PAR%SIM_%CTYPE .EQ. 'fc') ! 'type' is forecast (gribCode=9) + CONDITION1(2) = (IFS_PAR%SIM_%LOBSC1) ! .T. = term of observations included in configuration 1 + + ! Second special case + CONDITION2(1) = (IFS_PAR%SIM_%LVAREPS) ! .T. when running with variable resolution + CONDITION2(2) = (IFS_PAR%SIM_%NLEG .GE. 2) ! current VAREPS leg number (eg 1(2) for the T399(T255) part of a T399-T255 VAREPS) + + ! TODO: Need to handle the analysis case and in that case add the offset to the date/time + ! If needed modify the time + IF ( ALL(CONDITION1) ) THEN + ! NOTE: This code works because NSTEPINI is supposed to be less than 24 + ! NSTEPINI: Initial step in hours for the initial conditions + ! at the beginning of 4D-Var trajectory (usually 3 hours). + ! It is used to update the step while saving the FCs along + ! the first trajectory. + THH1 = THH - IFS_PAR%SIM_%NSTEPINI + IF ( THH1 .LT. 0 ) THEN + THH1 = THH1 + 24 + ! TODO: Replace custom function with Julian date provided in eccodes + PP_TRYCALL(ERRFLAG_UNABLE_TO_SUB_DAYS) DATE_SUB_DAYS( DYYYY, DMM, DDD, INT(-1,JPIB_K), DYYYY1, DMM1, DDD1, HOOKS ) + ENDIF + + ELSEIF ( ALL(CONDITION2) ) THEN + + ! NFCHO_TRUNC_INI: forecast step used to define the ICs (ie NFCHO_TRUNC of previous VAREPS LEG) + IFCDA_INI = IFS_PAR%SIM_%NFCHO_TRUNC_INI/24 + IFCHO_RES = MOD(IFS_PAR%SIM_%NFCHO_TRUNC_INI, 24) + THH1 = THH - IFCHO_RES + TMM1 = 0 + TSS1 = 0 + IF ( THH1 .LT. 0 ) THEN + THH1 = THH1 + 24 + IFCDA_INI = IFCDA_INI + 1 + ENDIF + ! TODO: Replace custom function with Julian date provided in eccodes + PP_TRYCALL(ERRFLAG_UNABLE_TO_SUB_DAYS) DATE_SUB_DAYS( DYYYY, DMM, DDD, -IFCDA_INI, DYYYY1, DMM1, DDD1, HOOKS ) + + ENDIF + + ! Output date and time + PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_DATE) PACK_YYYYMMDD( DYYYY1, DMM1, DDD1, DATE, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_TIME) PACK_HHMMSS( THH1, TMM1, TSS1, TIME, HOOKS ) + + ! Set the step + STEP = IFS_MSG%ISTEP_ + TIMESTEP_IN_SECONDS = INT( IFS_PAR%SIM_%TSTEP, KIND=JPIB_K ) + + ! TODO: If we do not set "timeproc" we rely on the default in the rules + ! MSG%TIMEPROC = 'instant' + + ! Check if the simulation is analysis + PP_TRYCALL(ERRFLAG_UNABLE_TO_CHECK_TYPE) IFS2MARS_IS_ANALYSIS( IFS_MSG, IFS_PAR, IS_ANALYSIS, HOOKS ) + + ! If it is analysis DATE/TIME/STEP should be set to the analysis time + IF ( IS_ANALYSIS ) THEN + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ANALYSIS) IFS2MARS_SET_ANALYSIS_TIME( & +& DATE, TIME, STEP, TIMESTEP_IN_SECONDS, MSG, PAR, HOOKS ) + ELSE + MSG%DATE = DATE + MSG%TIME = TIME + MSG%STEP = STEP + PAR%TIME%LENGTH_OF_TIME_STEP_IN_SECONDS_ = TIMESTEP_IN_SECONDS + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() ! Exit point (on success) RETURN -END FUNCTION IFS2MARS_INFER_SH_REPRES_FROM_IFS +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNABLE_TO_UNPACK_DATETIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in unpacking date/time' ) + CASE(ERRFLAG_UNABLE_TO_CONVER_SECONDS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in converting seconds to HH:MM:SS' ) + CASE(ERRFLAG_UNABLE_TO_PACK_DATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing date' ) + CASE(ERRFLAG_UNABLE_TO_PACK_TIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing time' ) + CASE(ERRFLAG_UNABLE_TO_SUB_DAYS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in subtracting days' ) + CASE(ERRFLAG_UNABLE_TO_CHECK_TYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in checking the type of simulation' ) + CASE(ERRFLAG_UNABLE_TO_SET_ANALYSIS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in setting the analysis time' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION IFS2MARS_SET_DATETIME #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_GET_GG_REPRES_DEFINITION' -PP_THREAD_SAFE FUNCTION IFS2MARS_GET_GG_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAME, GRID_DEFINITION, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'IFS2MARS_SET_ANALYSIS_TIME' +PP_THREAD_SAFE FUNCTION IFS2MARS_SET_ANALYSIS_TIME( DATE, TIME, STEP, & +& TIMESTEP_IN_SECONDS, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T + USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T - USE :: REDUCED_GG_MAP_MOD, ONLY: REDUCED_GG_GEOMETRY_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: DATETIME_UTILS_MOD, ONLY: SEC2DD_SS + USE :: DATETIME_UTILS_MOD, ONLY: SEC2HH_MM_SS + USE :: DATETIME_UTILS_MOD, ONLY: HH_MM_SS2SEC + USE :: DATETIME_UTILS_MOD, ONLY: UNPACK_HHMMSS + USE :: DATETIME_UTILS_MOD, ONLY: PACK_HHMMSS + USE :: DATETIME_UTILS_MOD, ONLY: DATE_SUM_DAYS + USE :: DATETIME_UTILS_MOD, ONLY: UNPACK_YYYYMMDD + USE :: DATETIME_UTILS_MOD, ONLY: PACK_YYYYMMDD ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1988,15 +2235,41 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_GG_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - CHARACTER(LEN=8), INTENT(IN) :: NAME - TYPE(REDUCED_GG_GEOMETRY_T), POINTER, INTENT(OUT) :: GRID_DEFINITION - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + INTEGER(KIND=JPIB_K), INTENT(IN) :: DATE + INTEGER(KIND=JPIB_K), INTENT(IN) :: TIME + INTEGER(KIND=JPIB_K), INTENT(IN) :: STEP + INTEGER(KIND=JPIB_K), INTENT(IN) :: TIMESTEP_IN_SECONDS + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET + ! Local variabels + INTEGER(KIND=JPIB_K) :: IN_YYYY + INTEGER(KIND=JPIB_K) :: IN_MN + INTEGER(KIND=JPIB_K) :: IN_DD + INTEGER(KIND=JPIB_K) :: DELTA_DD + INTEGER(KIND=JPIB_K) :: OUT_YYYY + INTEGER(KIND=JPIB_K) :: OUT_MN + INTEGER(KIND=JPIB_K) :: OUT_DD + INTEGER(KIND=JPIB_K) :: HH + INTEGER(KIND=JPIB_K) :: MS + INTEGER(KIND=JPIB_K) :: SS + INTEGER(KIND=JPIB_K) :: SEC + INTEGER(KIND=JPIB_K) :: TOTAL_SEC + + ! Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_EXTRACT_HH_MM_SS=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_SECONDS=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_DAYS=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_HH_MM_SS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_TIME=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: UNABLE_TO_UNPACK_DATE=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SUM_DAYS=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PACK_DATE=8_JPIB_K + ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2012,7 +2285,21 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_GG_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! TODO + ! TODO: To be verified, THis logic uses gregorian calendar (Functions copied from IFS, but probably julian calendar need to be used) + PP_TRYCALL(ERRFLAG_UNABLE_TO_EXTRACT_HH_MM_SS) UNPACK_HHMMSS( TIME, HH, MS, SS, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_SECONDS) HH_MM_SS2SEC( HH, MS, SS, SEC, HOOKS ) + + TOTAL_SEC = SEC + STEP*TIMESTEP_IN_SECONDS + + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_DAYS) SEC2DD_SS( TOTAL_SEC, DELTA_DD, SEC, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_HH_MM_SS) SEC2HH_MM_SS( SEC, HH, MS, SS, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_TIME) PACK_HHMMSS( HH, MS, SS, MSG%TIME, HOOKS ) + + PP_TRYCALL(UNABLE_TO_UNPACK_DATE) UNPACK_YYYYMMDD( DATE, IN_YYYY, IN_MN, IN_DD, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SUM_DAYS) DATE_SUM_DAYS( IN_YYYY, IN_MN, IN_DD, DELTA_DD, OUT_YYYY, OUT_MN, OUT_DD, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PACK_DATE) PACK_YYYYMMDD( OUT_YYYY, OUT_MN, OUT_DD, MSG%DATE, HOOKS ) + + MSG%STEP = 0_JPIB_K ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -2020,21 +2307,71 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_GG_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM ! Exit point (on success) RETURN -END FUNCTION IFS2MARS_GET_GG_REPRES_DEFINITION +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE(ERRFLAG_UNABLE_TO_EXTRACT_HH_MM_SS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in extracting HH:MM:SS' ) + CASE(ERRFLAG_UNABLE_TO_CONVERT_SECONDS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in converting seconds' ) + CASE(ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_DAYS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in converting seconds to days' ) + CASE(ERRFLAG_UNABLE_TO_CONVERT_SECONDS_TO_HH_MM_SS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in converting seconds to HH:MM:SS' ) + CASE(ERRFLAG_UNABLE_TO_PACK_TIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing time' ) + CASE(UNABLE_TO_UNPACK_DATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in unpacking date' ) + CASE(ERRFLAG_UNABLE_TO_SUM_DAYS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in summing days' ) + CASE(ERRFLAG_UNABLE_TO_PACK_DATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in packing date' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION IFS2MARS_SET_ANALYSIS_TIME #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'IFS2MARS_GET_SH_REPRES_DEFINITION' -PP_THREAD_SAFE FUNCTION IFS2MARS_GET_SH_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAME, SPHERICAL_HARMONICS_DEFINITIONS, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'IFS2MARS_NEEDS_PV_ARRAY' +PP_THREAD_SAFE FUNCTION IFS2MARS_NEEDS_PV_ARRAY( IFS_MSG, IFS_PAR, NEEDS_PV_ARRAY, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. - USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T - USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T - USE :: SPHERICAL_HARMONICS_MAP_MOD, ONLY: SPHERICAL_HARMONICS_T + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A + USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T + USE :: ENUMERATORS_MOD, ONLY: PREFIX_MODEL_LEVEL_E ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -2048,11 +2385,10 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_SH_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - CHARACTER(LEN=8), INTENT(IN) :: NAME - TYPE(SPHERICAL_HARMONICS_T), POINTER, INTENT(OUT) :: SPHERICAL_HARMONICS_DEFINITIONS - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CLASS(OM_BASE_MSG_A), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + LOGICAL, INTENT(OUT) :: NEEDS_PV_ARRAY + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET @@ -2072,7 +2408,12 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_SH_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! TODO + ! At the moment we need the PV array only for the model levels + IF ( IFS_MSG%IPREF_ .EQ. PREFIX_MODEL_LEVEL_E ) THEN + NEEDS_PV_ARRAY = .TRUE. + ELSE + NEEDS_PV_ARRAY = .FALSE. + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -2080,7 +2421,7 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_GET_SH_REPRES_DEFINITION( IFS_MSG, IFS_PAR, NAM ! Exit point (on success) RETURN -END FUNCTION IFS2MARS_GET_SH_REPRES_DEFINITION +END FUNCTION IFS2MARS_NEEDS_PV_ARRAY #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE @@ -2092,7 +2433,9 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_LEVELIST( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T @@ -2110,7 +2453,7 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_LEVELIST( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG + CLASS(OM_BASE_MSG_A), INTENT(IN) :: IFS_MSG TYPE(MODEL_PAR_T), TARGET, INTENT(IN) :: IFS_PAR TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR @@ -2126,6 +2469,7 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_LEVELIST( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NEEDS_PV_ARRAY=1_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PARAMETRIZATION=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNKNOWN_CLASS=3_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2156,8 +2500,15 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_LEVELIST( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ! PAR%LEVELS%PV => NULL() ENDIF - ! Set level and levtype - MSG%LEVELIST = IFS_MSG%ILEVG_ + ! Set levelist + SELECT TYPE(A => IFS_MSG) + CLASS IS (OM_ATM_MSG_T) + MSG%LEVELIST = A%ILEVG_ + CLASS IS (OM_WAM_MSG_T) + MSG%LEVELIST = 0_JPIB_K + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_CLASS ) + END SELECT ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -2183,6 +2534,10 @@ PP_THREAD_SAFE FUNCTION ATM2MARS_SET_LEVELIST( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS SELECT CASE(ERRIDX) CASE(ERRFLAG_NEEDS_PV_ARRAY) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in calling IFS2MARS_NEEDS_PV_ARRAY' ) + ! CASE(ERRFLAG_UNABLE_TO_SET_PARAMETRIZATION) + ! PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in setting the parametrization' ) + CASE(ERRFLAG_UNKNOWN_CLASS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unknown class' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -2208,23 +2563,20 @@ END FUNCTION ATM2MARS_SET_LEVELIST #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'IFS2MARS_SET_GEOMETRY' -PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, REPRESENTATIONS, MSG, PAR, HOOKS ) RESULT(RET) +PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, GG_GRID_NAME, SH_GRID_NAME, REPRESENTATIONS, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K USE :: HOOKS_MOD, ONLY: HOOKS_T USE :: GEOMETRY_PAR_MOD, ONLY: GEOMETRY_PAR_T - USE :: IFS_MSG_MOD, ONLY: OM_ATM_MSG_T + USE :: IFS_MSG_MOD, ONLY: OM_BASE_MSG_A USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T USE :: ENUMERATORS_MOD, ONLY: REPRES_LATLONG_E USE :: ENUMERATORS_MOD, ONLY: REPRES_GAUSSIANGRID_E USE :: ENUMERATORS_MOD, ONLY: REPRES_SPHERICALHARMONICS_E - - USE :: REGULAR_LL_MAP_MOD, ONLY: REGULAR_LL_GEOMETRY_T - USE :: REDUCED_GG_MAP_MOD, ONLY: REDUCED_GG_GEOMETRY_T - USE :: SPHERICAL_HARMONICS_MAP_MOD, ONLY: SPHERICAL_HARMONICS_T + USE :: REPRES_MAP_MOD, ONLY: REPRES_MAP_T ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -2238,34 +2590,20 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, REPRESENTATIONS IMPLICIT NONE ! Dummy arguments - TYPE(OM_ATM_MSG_T), INTENT(IN) :: IFS_MSG - TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR - TYPE(GEOMETRY_PAR_T), TARGET, INTENT(IN) :: REPRESENTATIONS - TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG - TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR - TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CLASS(OM_BASE_MSG_A), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), INTENT(IN) :: IFS_PAR + CHARACTER(LEN=*), INTENT(IN) :: GG_GRID_NAME + CHARACTER(LEN=*), INTENT(IN) :: SH_GRID_NAME + TYPE(REPRES_MAP_T), TARGET, INTENT(IN) :: REPRESENTATIONS + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS ! Function result INTEGER(KIND=JPIB_K) :: RET - ! Local variables - LOGICAL :: LMATCH - TYPE(REGULAR_LL_GEOMETRY_T), POINTER :: LL_REPRES_DESCRIPTION - TYPE(REDUCED_GG_GEOMETRY_T), POINTER :: GG_REPRES_DESCRIPTION - TYPE(SPHERICAL_HARMONICS_T), POINTER :: SH_REPRES_DESCRIPTION - ! Error flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_IMPLEMENTED=1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNKNOWN_REPRES=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INFER_GG_REPRES_FROM_IFS=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_CHECK_GG_REPRES=4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GENERATE_GG_REPRES=5_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_PUSH_GG_REPRES=6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_INFER_SH_REPRES_FROM_IFS=7_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_CHECK_SH_REPRES=8_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_GENERATE_SH_REPRES=9_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_PUSH_SH_REPRES=10_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_REPRES_NOT_ASSOCIATED=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNSUPPORTED_GEOMETRY=1_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2282,74 +2620,167 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, REPRESENTATIONS ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! At the moment we need the PV array only for the model levels - SELECT CASE ( IFS_MSG%IREPRES_ ) + IF ( IFS_MSG%IREPRES_ .EQ. REPRES_GAUSSIANGRID_E ) THEN + MSG%REPRES = REPRES_GAUSSIANGRID_E + MSG%GRID = TRIM(ADJUSTL(GG_GRID_NAME)) + ELSEIF ( IFS_MSG%IREPRES_ .EQ. REPRES_SPHERICALHARMONICS_E ) THEN + MSG%REPRES = REPRES_SPHERICALHARMONICS_E + ! MSG%GRID = TRIM(ADJUSTL(SH_GRID_NAME)) + MSG%TRUNCATION = IFS_PAR%GEO_%ISMAX + ELSE + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNSUPPORTED_GEOMETRY ) + ENDIF - ! ================================================================================================ - CASE (REPRES_LATLONG_E) + ! TODO: Handle the rotation on sh representations triggered throug the following conditions + ! IF ( THIS%MODEL_PAR_%GEO_%NSTTYP .GE. 2_JPIB_K ) THEN + ! ELSEIF ( ABS(THIS%MODEL_PAR_%GEO_%RSTRET-1.0_JPRD_K) .GE. 1.0E-14_JPRD_K ) THEN - ! Unexpected regular latlon from IFS - LL_REPRES_DESCRIPTION => NULL() - PP_DEBUG_CRITICAL_THROW( ERRFLAG_NOT_IMPLEMENTED ) + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() - ! ================================================================================================ - CASE (REPRES_GAUSSIANGRID_E) + ! Exit point (on success) + RETURN - GG_REPRES_DESCRIPTION => NULL() - MSG%REPRES = REPRES_GAUSSIANGRID_E +! Error handler +PP_ERROR_HANDLER - PAR%GEOMETRY%LL_TO_BE_DEALLOCATED = .FALSE. - PAR%GEOMETRY%GG_TO_BE_DEALLOCATED = .FALSE. - PAR%GEOMETRY%SH_TO_BE_DEALLOCATED = .FALSE. + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) - PAR%GEOMETRY%LL => NULL() - PAR%GEOMETRY%GG => REPRESENTATIONS%GG - PAR%GEOMETRY%SH => NULL() +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) - ! Infer grid (type) from if parameters - PP_TRYCALL(ERRFLAG_INFER_GG_REPRES_FROM_IFS) IFS2MARS_INFER_GG_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, MSG%GRID, HOOKS ) + BLOCK - ! Check if the grid definition is already in the parameters - PP_TRYCALL(ERRFLAG_CHECK_GG_REPRES) PAR%GEOMETRY%GG%MATCH( MSG%GRID, LMATCH, HOOKS ) + ! Error handling variables + PP_DEBUG_PUSH_FRAME() - ! If the grid is not already in the parameters, then set it - IF ( .NOT. LMATCH ) THEN - PP_TRYCALL(ERRFLAG_GENERATE_GG_REPRES) IFS2MARS_GET_GG_REPRES_DEFINITION( IFS_MSG, IFS_PAR, MSG%GRID, GG_REPRES_DESCRIPTION, HOOKS ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.ASSOCIATED(GG_REPRES_DESCRIPTION), ERRFLAG_REPRES_NOT_ASSOCIATED ) - PP_TRYCALL(ERRFLAG_PUSH_GG_REPRES) PAR%GEOMETRY%GG%PUSH( MSG%GRID, GG_REPRES_DESCRIPTION, HOOKS ) - ENDIF + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT - ! ================================================================================================ - CASE (REPRES_SPHERICALHARMONICS_E) + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() - SH_REPRES_DESCRIPTION => NULL() - MSG%REPRES = REPRES_SPHERICALHARMONICS_E + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK - PAR%GEOMETRY%LL_TO_BE_DEALLOCATED = .FALSE. - PAR%GEOMETRY%GG_TO_BE_DEALLOCATED = .FALSE. - PAR%GEOMETRY%SH_TO_BE_DEALLOCATED = .FALSE. +!$omp end critical(ERROR_HANDLER) +#endif - PAR%GEOMETRY%LL => NULL() - PAR%GEOMETRY%GG => NULL() - PAR%GEOMETRY%SH => REPRESENTATIONS%SH + ! Exit point (on error) + RETURN + +END FUNCTION IFS2MARS_SET_GEOMETRY +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE - ! Infer grid (type) from if parameters - PP_TRYCALL(ERRFLAG_INFER_SH_REPRES_FROM_IFS) IFS2MARS_INFER_SH_REPRES_FROM_IFS( IFS_MSG, IFS_PAR, MSG%GRID, HOOKS ) - ! Check if the grid definition is already in the parameters - PP_TRYCALL(ERRFLAG_CHECK_SH_REPRES) PAR%GEOMETRY%SH%MATCH( MSG%GRID, LMATCH, HOOKS ) - ! If the grid is not already in the parameters, then set it - IF ( .NOT. LMATCH ) THEN - PP_TRYCALL(ERRFLAG_GENERATE_SH_REPRES) IFS2MARS_GET_SH_REPRES_DEFINITION( IFS_MSG, IFS_PAR, MSG%GRID, SH_REPRES_DESCRIPTION, HOOKS ) - PP_DEBUG_CRITICAL_COND_THROW( .NOT.ASSOCIATED(SH_REPRES_DESCRIPTION), ERRFLAG_REPRES_NOT_ASSOCIATED ) - PP_TRYCALL(ERRFLAG_PUSH_SH_REPRES) PAR%GEOMETRY%SH%PUSH( MSG%GRID, SH_REPRES_DESCRIPTION, HOOKS ) - ENDIF - ! ================================================================================================ - CASE DEFAULT - PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNKNOWN_REPRES ) - END SELECT + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'WAM2MARS_SET_DIRFREQ' +PP_THREAD_SAFE FUNCTION WAM2MARS_SET_DIRFREQ( IFS_MSG, IFS_PAR, MSG, PAR, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T + USE :: IFS_PAR_MOD, ONLY: MODEL_PAR_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: ENUMERATORS_MOD, ONLY: LEVTYPE_SFC_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + TYPE(OM_WAM_MSG_T), INTENT(IN) :: IFS_MSG + TYPE(MODEL_PAR_T), TARGET, INTENT(IN) :: IFS_PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + ! Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables + LOGICAL IS_WAVE_SPECTRA + + ! Error handling variables + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_IS_SPECTRA=0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_TH_ALLOCATED=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_FR_ALLOCATED=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS_FRLB=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS_FRUB=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS_THLB=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_OUT_OF_BOUNDS_THUB=6_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! TODO: if it is wave spectra then we need to set the frequency and direction, + ! otherwise need to set level and levetype + PP_TRYCALL(ERRFLAG_IS_SPECTRA) WAM2MARS_IS_WAVE_SPECTRA( IFS_MSG, IFS_PAR, IS_WAVE_SPECTRA, HOOKS ) + + IF ( IS_WAVE_SPECTRA ) THEN + + ! Error handling + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(IFS_PAR%WAM_%TH), ERRFLAG_NOT_TH_ALLOCATED ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(IFS_PAR%WAM_%FR), ERRFLAG_NOT_FR_ALLOCATED ) + PP_DEBUG_CRITICAL_COND_THROW( IFS_MSG%IANGLE .LT. 1_JPIB_K, ERRFLAG_OUT_OF_BOUNDS_THLB ) + PP_DEBUG_CRITICAL_COND_THROW( IFS_MSG%IANGLE .GT. SIZE(IFS_PAR%WAM_%TH), ERRFLAG_OUT_OF_BOUNDS_THUB ) + PP_DEBUG_CRITICAL_COND_THROW( IFS_MSG%IFREQ .LT. 1_JPIB_K, ERRFLAG_OUT_OF_BOUNDS_FRLB ) + PP_DEBUG_CRITICAL_COND_THROW( IFS_MSG%IFREQ .GT. SIZE(IFS_PAR%WAM_%FR), ERRFLAG_OUT_OF_BOUNDS_FRUB ) + + ! Set the direction of the frequency + ! NOTE: It may make sense to scale the frequency with the direction here + ! TODO: Scaling of frequency may require more info + ! PP_METADATA_SET( METADATA, 'numberOfWaveDirections', MODEL_PARAMS%WAM_%NANG ) + ! PP_METADATA_SET( METADATA, 'scaleFactorOfWaveDirections', IDIRSCALING ) + ! PP_METADATA_SET( METADATA, 'scaledValuesOfWaveDirections', SCTH ) + ! PP_METADATA_SET( METADATA, 'numberOfWaveFrequencies', MODEL_PARAMS%WAM_%NFRE_RED ) + ! PP_METADATA_SET( METADATA, 'scaleFactorOfWaveFrequencies', IFRESCALING ) + ! PP_METADATA_SET( METADATA, 'scaledValuesOfWaveFrequencies', SCFR ) + MSG%DIRECTION = IFS_MSG%IANGLE + MSG%FREQUENCY = IFS_MSG%IFREQ + PAR%WAVE%TO_BE_DEALLOCATED = .FALSE. + PAR%WAVE%DIRS_ => IFS_PAR%WAM_%TH + PAR%WAVE%FREQ_ => IFS_PAR%WAM_%FR + + ELSE + + MSG%LEVTYPE = LEVTYPE_SFC_E + + ! TODO Not sure if levelist has to be set here (for surfaces is always 0) + MSG%LEVELIST = 0_JPIB_K + + ENDIF ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -2368,33 +2799,50 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, REPRESENTATIONS BLOCK + ! Local debug variables + INTEGER(KIND=JPIB_K) :: DUMMYSTAT + CHARACTER(LEN=32) :: GOT + CHARACTER(LEN=32) :: EXPECTED + ! Error handling variables PP_DEBUG_PUSH_FRAME() ! Handle different errors SELECT CASE(ERRIDX) - CASE(ERRFLAG_NOT_IMPLEMENTED) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unexpected regular latlon from IFS' ) - CASE(ERRFLAG_UNKNOWN_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unknown representation' ) - CASE(ERRFLAG_INFER_GG_REPRES_FROM_IFS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in calling IFS2MARS_INFER_GG_REPRES_FROM_IFS' ) - CASE(ERRFLAG_CHECK_GG_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in checking GG representation' ) - CASE(ERRFLAG_GENERATE_GG_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in generating GG representation' ) - CASE(ERRFLAG_PUSH_GG_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in pushing GG representation' ) - CASE(ERRFLAG_INFER_SH_REPRES_FROM_IFS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in calling IFS2MARS_INFER_SH_REPRES_FROM_IFS' ) - CASE(ERRFLAG_CHECK_SH_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in checking SH representation' ) - CASE(ERRFLAG_GENERATE_SH_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in generating SH representation' ) - CASE(ERRFLAG_PUSH_SH_REPRES) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in pushing SH representation' ) - CASE(ERRFLAG_REPRES_NOT_ASSOCIATED) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Representation not associated' ) + CASE(ERRFLAG_IS_SPECTRA) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error in checking for wave spectra' ) + CASE(ERRFLAG_NOT_TH_ALLOCATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Direction not allocated' ) + CASE(ERRFLAG_NOT_FR_ALLOCATED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Frequency not allocated' ) + CASE(ERRFLAG_OUT_OF_BOUNDS_FRLB) + GOT=REPEAT(' ',32) + WRITE(GOT, '(I32)', IOSTAT=DUMMYSTAT) IFS_MSG%IFREQ + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Frequency lower bound out of bounds' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Got: '//TRIM(ADJUSTL(GOT)) ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Expected: bigger than 0' ) + CASE(ERRFLAG_OUT_OF_BOUNDS_FRUB) + GOT=REPEAT(' ',32) + EXPECTED=REPEAT(' ',32) + WRITE(GOT, '(I32)', IOSTAT=DUMMYSTAT) IFS_MSG%IFREQ + WRITE(EXPECTED, '(I32)', IOSTAT=DUMMYSTAT) SIZE(IFS_PAR%WAM_%FR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Frequency upper bound out of bounds' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Expected: lower or equal to -> '//TRIM(ADJUSTL(EXPECTED)) ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Got: '//TRIM(ADJUSTL(GOT)) ) + CASE(ERRFLAG_OUT_OF_BOUNDS_THLB) + GOT=REPEAT(' ',32) + WRITE(GOT, '(I32)', IOSTAT=DUMMYSTAT) IFS_MSG%IANGLE + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Direction lower bound out of bounds' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Got: '//TRIM(ADJUSTL(GOT)) ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Expected: bigger than 0' ) + CASE(ERRFLAG_OUT_OF_BOUNDS_THUB) + GOT=REPEAT(' ',32) + EXPECTED=REPEAT(' ',32) + WRITE(GOT, '(I32)', IOSTAT=DUMMYSTAT) IFS_MSG%IANGLE + WRITE(EXPECTED, '(I32)', IOSTAT=DUMMYSTAT) SIZE(IFS_PAR%WAM_%TH) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Direction upper bound out of bounds' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Expected: lower or equal to -> '//TRIM(ADJUSTL(EXPECTED)) ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Got: '//TRIM(ADJUSTL(GOT)) ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) END SELECT @@ -2413,7 +2861,7 @@ PP_THREAD_SAFE FUNCTION IFS2MARS_SET_GEOMETRY( IFS_MSG, IFS_PAR, REPRESENTATIONS ! Exit point (on error) RETURN -END FUNCTION IFS2MARS_SET_GEOMETRY +END FUNCTION WAM2MARS_SET_DIRFREQ #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE diff --git a/src/multiom/operations/intop/CMakeLists.txt b/src/multiom/operations/intop/CMakeLists.txt index 2706748bd..69c03b457 100644 --- a/src/multiom/operations/intop/CMakeLists.txt +++ b/src/multiom/operations/intop/CMakeLists.txt @@ -15,6 +15,7 @@ set( MULTIOM_OPERATIONS_INTOP_MAIN_SOURCES ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_binary_op_mod.F90 ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_unary_op_mod.F90 ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_constant_mod.F90 + ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_enum_mod.F90 ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_message_mod.F90 ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_parametrization_mod.F90 ${MULTIOM_OPERATIONS_INTOP_DIR}/intop_factory_mod.F90 diff --git a/src/multiom/operations/intop/intop_enum_mod.F90 b/src/multiom/operations/intop/intop_enum_mod.F90 new file mode 100644 index 000000000..b8a61156f --- /dev/null +++ b/src/multiom/operations/intop/intop_enum_mod.F90 @@ -0,0 +1,685 @@ +!> +!> @file intop_enum_mod.F90 +!> +!> @brief Module containing definitions and procedures for enumeter operations. +!> +!> This module defines the `INTOP_ENUM_T` type, along with its associated +!> procedures and helper functions that facilitate the creation, management, and +!> utilization of enumeter operations within the system. ENUMeter operations allow for +!> complex operationing operations by combining multiple nested operations. +!> +!> @author Mirco Valentini +!> @date August, 2024 +!> + +! Include preprocessor utils +#include "output_manager_preprocessor_utils.h" +#include "output_manager_preprocessor_trace_utils.h" +#include "output_manager_preprocessor_logging_utils.h" +#include "output_manager_preprocessor_errhdl_utils.h" + + +#define PP_FILE_NAME 'intop_enum_mod.F90' +#define PP_SECTION_TYPE 'MODULE' +#define PP_SECTION_NAME 'INTOP_ENUM_MOD' +MODULE INTOP_ENUM_MOD + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: INTOP_BASE_MOD, ONLY: INTOP_BASE_A + +IMPLICIT NONE + +!> Default visibility of the module +PRIVATE + +!> +!> @brief A type representing a operation with support for nested operations and matching logic. +!> +!> This derived type extends `INTOP_BASE_A` and is used for operationing based on enumeters. +!> It supports matching, ignoring, or applying thresholds to specific enumeters, and can +!> also utilize a keyset to perform nested operationing. +!> +TYPE, EXTENDS(INTOP_BASE_A) :: INTOP_ENUM_T + + !> Default visibility of the type. + PRIVATE + + !> Enumerators for field and value + INTEGER(KIND=JPIB_K) :: FIELD_ID_=-99_JPIB_K + INTEGER(KIND=JPIB_K) :: VALUE_ID_=-99_JPIB_K + +CONTAINS + + !> @brief Initializes the operation enumeter type. + !> @details This procedure sets up the `INTOP_ENUM_T` type, initializing its components. + !> + !> @enum [in] this The instance of `INTOP_ENUM_T` to initialize. + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: INIT => INTOP_ENUM_INIT + + !> @brief Matches a condition against the operation. + !> @details This procedure checks whether a given condition matches the criteria defined by the operation. + !> + !> @enum [in] this The instance of `INTOP_ENUM_T`. + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: EVAL => INTOP_ENUM_EVAL + + !> @brief Prints the operation's details for debugging or logging. + !> @details Outputs the operation's configuration and current state. + !> + !> @enum [in] this The instance of `INTOP_ENUM_T` to print. + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: PRINT => INTOP_ENUM_PRINT + + !> @brief Frees resources allocated for the operation. + !> @details Cleans up the `INTOP_ENUM_T` type, deallocating any resources used by the operation. + !> + !> @enum [in] this The instance of `INTOP_ENUM_T` to free. + PROCEDURE, NON_OVERRIDABLE, PUBLIC, PASS :: FREE => INTOP_ENUM_FREE + +END TYPE + + + +!> Whitlist of public symbols +PUBLIC :: INTOP_ENUM_T + +CONTAINS + + +!> +!> @brief Initializes the `INTOP_ENUM_T` operation from a YAML configuration. +!> +!> This function initializes the `INTOP_ENUM_T` type based on the provided YAML +!> configuration (`CFG`) and applies any hooks specified in `HOOKS`. The function +!> reads the necessary enumeters from the configuration and sets up the operation structure. +!> +!> @enum [inout] THIS The operation object (`INTOP_ENUM_T`) that will be initialized. +!> @enum [in] CFG The YAML configuration object containing the operation settings. +!> @enum [in] OPT The generic options to be used to initialize the operation. +!> @enum [inout] HOOKS A structure (`HOOKS_T`) used for additional hooks or callbacks during initialization. +!> +!> @return Integer error code (`RET`) indicating the success or failure of the initialization. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +!> @section local dependencies +!> @dependency [TYPE] DATAKINDS_DEF_MOD::JPIB_K +!> @dependency [TYPE] YAML_CORE_UTILS_MOD::YAML_CONFIGURATION_T +!> @dependency [TYPE] HOOKS_MOD::HOOKS_T +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_CONFIGURATION_HAS_KEY +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_GET_SUBCONFIGURATIONS +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_GET_CONFIGURATIONS_SIZE +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_GET_CONFIGURATION_BY_ID +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_READ_STRING +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_READ_INTEGER +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_READ_INTEGER_KEYSET_WITH_RANGES +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_DELETE_CONFIGURATION +!> @dependency [PROCEDURE] YAML_CORE_UTILS_MOD::YAML_DELETE_CONFIGURATIONS +!> +!> @section special dependencies +!> @dependency [*] PP_DEBUG_USE_VARS::* +!> @dependency [*] PP_LOG_USE_VARS::* +!> @dependency [*] PP_TRACE_USE_VARS::* +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INTOP_ENUM_INIT' +FUNCTION INTOP_ENUM_INIT( THIS, CFG, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: YAML_CORE_UTILS_MOD, ONLY: YAML_CONFIGURATION_T + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: YAML_CORE_UTILS_MOD, ONLY: YAML_CONFIGURATION_HAS_KEY + USE :: YAML_CORE_UTILS_MOD, ONLY: YAML_READ_STRING + USE :: YAML_CORE_UTILS_MOD, ONLY: YAML_READ_STRING_WITH_ENV_EXPANSION + USE :: CONFIGURATION_UTILS_MOD, ONLY: STRING_IS_INTEGER + USE :: CONFIGURATION_UTILS_MOD, ONLY: STRING_TO_INTEGER + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: CMSGINTFLDS2IMSGINTFLDS + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_STREAM_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TYPE_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_CLASS_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_LEVTYPE_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_REPRES_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_PACKING_E + USE :: ENUMERATORS_MOD, ONLY: CSTREAM2ISTREAM + USE :: ENUMERATORS_MOD, ONLY: CTYPE2ITYPE + USE :: ENUMERATORS_MOD, ONLY: CCLASS2ICLASS + USE :: ENUMERATORS_MOD, ONLY: CPACKING2IPACKING + USE :: ENUMERATORS_MOD, ONLY: CREPRES2IREPRES + USE :: ENUMERATORS_MOD, ONLY: CLEVTYPE2ILEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(INTOP_ENUM_T), INTENT(INOUT) :: THIS + TYPE(YAML_CONFIGURATION_T), INTENT(IN) :: CFG + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + LOGICAL :: HAS_VALUE + LOGICAL :: HAS_NAME + LOGICAL :: IS_INTEGER + CHARACTER(LEN=:), ALLOCATABLE :: CTMP + INTEGER(KIND=JPIB_K) :: DEALLOC_STATE + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: FIELD_ID + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_READ_OPERATION = 1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_VALUE_UNDEFINED = 2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_TYPE_NOT_ALLOCATED_AFTER_READ = 4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_INTEGER = 5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_NOT_INTEGER = 6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE = 7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM = 8_JPIB_K + + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + !> Read the enum + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_OPERATION ) YAML_CONFIGURATION_HAS_KEY( CFG, 'name', HAS_NAME, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT. HAS_NAME, ERRFLAG_VALUE_UNDEFINED ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_OPERATION) YAML_READ_STRING( CFG, 'name', CTMP, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(CTMP), ERRFLAG_TYPE_NOT_ALLOCATED_AFTER_READ ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CMSGINTFLDS2IMSGINTFLDS( CTMP, THIS%FIELD_ID_, HOOKS ) + DEALLOCATE(CTMP, STAT=DEALLOC_STATE, ERRMSG=ERRMSG) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATE .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + + + + !> Read the enum + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_OPERATION ) YAML_CONFIGURATION_HAS_KEY( CFG, 'value', HAS_VALUE, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT. HAS_VALUE, ERRFLAG_VALUE_UNDEFINED ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_READ_OPERATION) YAML_READ_STRING_WITH_ENV_EXPANSION( CFG, 'value', CTMP, HOOKS ) + PP_DEBUG_CRITICAL_COND_THROW( .NOT.ALLOCATED(CTMP), ERRFLAG_TYPE_NOT_ALLOCATED_AFTER_READ ) + + SELECT CASE (THIS%FIELD_ID_) + CASE (MSGINTFLD_STREAM_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CSTREAM2ISTREAM( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE (MSGINTFLD_TYPE_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CTYPE2ITYPE( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE (MSGINTFLD_CLASS_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CCLASS2ICLASS( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE (MSGINTFLD_LEVTYPE_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CLEVTYPE2ILEVTYPE( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE (MSGINTFLD_REPRES_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CREPRES2IREPRES( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE (MSGINTFLD_PACKING_E) + PP_TRYCALL(ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) CPACKING2IPACKING( CTMP, THIS%VALUE_ID_, HOOKS ) + CASE DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM ) + END SELECT + + ! Deallocate the value + DEALLOCATE(CTMP, STAT=DEALLOC_STATE, ERRMSG=ERRMSG) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STATE .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_READ_OPERATION) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to read operation' ) + CASE (ERRFLAG_VALUE_UNDEFINED) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'value undefined' ) + CASE (ERRFLAG_TYPE_NOT_ALLOCATED_AFTER_READ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'type not allocated after read' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_INTEGER) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to convert to integer' ) + CASE (ERRFLAG_NOT_INTEGER) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'not integer' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to deallocate' ) + CASE (ERRFLAG_UNABLE_TO_CONVERT_TO_ENUM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to convert to enum' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION INTOP_ENUM_INIT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Matches a operation enumeter with a message and enumeter. +!> +!> This function checks whether the provided message (`MSG`) and enumeter (`PAR`) +!> match the operation's criteria. If a match is found, the `MATCH` flag is set to `.TRUE.`; +!> otherwise, it is set to `.FALSE.`. Hooks can be applied during the matching process +!> to allow additional processing. +!> +!> @enum [inout] THIS The operation object (`INTOP_ENUM_T`) used for matching. +!> @enum [in] MSG The message (`FORTRAN_MESSAGE_T`) that is checked against the operation. +!> @enum [in] PAR The enumeter object (`ENUMETRIZATION_T`) used in the matching process. +!> @enum [out] MATCH Logical flag indicating whether the message and enumeter match the operation's criteria. +!> @enum [inout] HOOKS A structure (`HOOKS_T`) used for additional hooks or callbacks during matching. +!> +!> @return Integer error code (`RET`) indicating success or failure of the matching process. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +!> @section local dependencies +!> @dependency [TYPE] DATAKINDS_DEF_MOD::JPIB_K +!> @dependency [TYPE] ENUMETRIZATION_MOD::ENUMETRIZATION_T +!> @dependency [TYPE] FORTRAN_MESSAGE_MOD::FORTRAN_MESSAGE_T +!> @dependency [TYPE] HOOKS_MOD::HOOKS_T +!> +!> @section special dependencies +!> @dependency [*] PP_DEBUG_USE_VARS::* +!> @dependency [*] PP_LOG_USE_VARS::* +!> @dependency [*] PP_TRACE_USE_VARS::* +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INTOP_ENUM_EVAL' +FUNCTION INTOP_ENUM_EVAL( THIS, MSG, PAR, RESULT, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T + USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T + USE :: HOOKS_MOD, ONLY: HOOKS_T + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(INTOP_ENUM_T), INTENT(INOUT) :: THIS + TYPE(FORTRAN_MESSAGE_T), INTENT(IN) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(IN) :: PAR + INTEGER(KIND=JPIB_K), INTENT(OUT) :: RESULT + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Return the result of the operation + RESULT = THIS%VALUE_ID_ + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +END FUNCTION INTOP_ENUM_EVAL +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Prints the operation's configuration and details to the specified output unit. +!> +!> This function prints the details of the operation to the output specified by the `UNIT`. +!> An `OFFSET` can be applied to format the output, and `HOOKS` can be used for additional +!> callbacks during the printing process. The printed output includes details about +!> the operation's current configuration. +!> +!> @enum [inout] THIS The operation object (`INTOP_ENUM_T`) whose details are to be printed. +!> @enum [in] UNIT The output unit (file or console) where the operation's details will be printed. +!> @enum [in] OFFSET The offset applied to the printed output for formatting purposes. +!> @enum [inout] HOOKS Structure (`HOOKS_T`) used for additional hooks or callbacks during printing. +!> +!> @return Integer error code (`RET`) indicating success or failure of the print operation. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +!> @section local dependencies +!> @dependency [TYPE] DATAKINDS_DEF_MOD::JPIB_K +!> @dependency [TYPE] HOOKS_MOD::HOOKS_T +!> @dependency [PROCEDURE] DESTROY_OPERATION (*to be implemented) +!> +!> @section special dependencies +!> @dependency [*] PP_DEBUG_USE_VARS::* +!> @dependency [*] PP_LOG_USE_VARS::* +!> @dependency [*] PP_TRACE_USE_VARS::* +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INTOP_ENUM_PRINT' +FUNCTION INTOP_ENUM_PRINT( THIS, UNIT, OFFSET, HOOKS, SEPARATOR ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: IMSGINTFLDS2CMSGINTFLDS + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_STREAM_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_TYPE_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_CLASS_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_LEVTYPE_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_REPRES_E + USE :: FORTRAN_MESSAGE_ENUMERATORS_MOD, ONLY: MSGINTFLD_PACKING_E + USE :: ENUMERATORS_MOD, ONLY: ISTREAM2CSTREAM + USE :: ENUMERATORS_MOD, ONLY: ITYPE2CTYPE + USE :: ENUMERATORS_MOD, ONLY: ICLASS2CCLASS + USE :: ENUMERATORS_MOD, ONLY: IPACKING2CPACKING + USE :: ENUMERATORS_MOD, ONLY: IREPRES2CREPRES + USE :: ENUMERATORS_MOD, ONLY: ILEVTYPE2CLEVTYPE + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(INTOP_ENUM_T), INTENT(INOUT) :: THIS + INTEGER(KIND=JPIB_K), INTENT(IN) :: UNIT + INTEGER(KIND=JPIB_K), INTENT(IN) :: OFFSET + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: SEPARATOR + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=16) :: FIELD_NAME + CHARACTER(LEN=32) :: FIELD_VALUE + CHARACTER(LEN=32) :: TMP + + !> Local error codes + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_CONVERT_TO_NAME = 1_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + + ! Extract field name + FIELD_NAME = REPEAT( ' ', 16 ) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) IMSGINTFLDS2CMSGINTFLDS( THIS%FIELD_ID_, FIELD_NAME, HOOKS ) + + ! Extract field value + FIELD_VALUE = REPEAT( ' ', 32 ) + SELECT CASE (THIS%FIELD_ID_) + CASE (MSGINTFLD_STREAM_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) ISTREAM2CSTREAM( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE (MSGINTFLD_TYPE_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) ITYPE2CTYPE( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE (MSGINTFLD_CLASS_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) ICLASS2CCLASS( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE (MSGINTFLD_LEVTYPE_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) ILEVTYPE2CLEVTYPE( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE (MSGINTFLD_REPRES_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) IREPRES2CREPRES( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE (MSGINTFLD_PACKING_E) + PP_TRYCALL(ERRFLAG_CONVERT_TO_NAME) IPACKING2CPACKING( THIS%VALUE_ID_, FIELD_VALUE, HOOKS ) + CASE DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_CONVERT_TO_NAME ) + END SELECT + + !> Print the enum operation + IF ( PRESENT(SEPARATOR) ) THEN + WRITE(UNIT,'(A)') REPEAT(' ',OFFSET)//'enum :: "'//TRIM(ADJUSTL(FIELD_NAME))//'":"'//TRIM(ADJUSTL(FIELD_VALUE))//'"'//TRIM(ADJUSTL(SEPARATOR)) + ELSE + WRITE(UNIT,'(A)') REPEAT(' ',OFFSET)//'enum :: "'//TRIM(ADJUSTL(FIELD_NAME))//'":"'//TRIM(ADJUSTL(FIELD_VALUE))//'"' + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_CONVERT_TO_NAME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unable to convert enum to name' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION INTOP_ENUM_PRINT +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + +!> +!> @brief Frees the memory and resources associated with the operation. +!> +!> This function deallocates the memory and resources used by the operation object. +!> It ensures proper cleanup of nested structures and any associated hooks. +!> After this function is called, the operation object should no longer be used. +!> +!> @enum [inout] THIS The operation object (`INTOP_ENUM_T`) whose resources are to be freed. +!> @enum [inout] HOOKS Structure (`HOOKS_T`) used for additional hooks or callbacks during the deallocation process. +!> +!> @return Integer error code (`RET`) indicating success or failure of the free operation. +!> Possible values: +!> - `0`: Success +!> - `1`: Failure +!> +!> @section local dependencies +!> @dependency [TYPE] DATAKINDS_DEF_MOD::JPIB_K +!> @dependency [TYPE] HOOKS_MOD::HOOKS_T +!> @dependency [PROCEDURE] DESTROY_OPERATION (*to be implemented) +!> +!> @section special dependencies +!> @dependency [*] PP_DEBUG_USE_VARS::* +!> @dependency [*] PP_LOG_USE_VARS::* +!> @dependency [*] PP_TRACE_USE_VARS::* +!> +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'INTOP_ENUM_FREE' +FUNCTION INTOP_ENUM_FREE( THIS, HOOKS ) RESULT(RET) + + !> Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: ENUMERATORS_MOD, ONLY: UNDEF_PARAM_E + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + !> Dummy arguments + CLASS(INTOP_ENUM_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + INTEGER(KIND=JPIB_K) :: I + INTEGER(KIND=JPIB_K) :: DEALLOC_STATE + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Reset members + THIS%FIELD_ID_ = UNDEF_PARAM_E + THIS%VALUE_ID_ = UNDEF_PARAM_E + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (On success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! Handle different errors + SELECT CASE(ERRIDX) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point (on error) + RETURN + +END FUNCTION INTOP_ENUM_FREE +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + +END MODULE INTOP_ENUM_MOD +#undef PP_SECTION_NAME +#undef PP_SECTION_TYPE +#undef PP_FILE_NAME \ No newline at end of file diff --git a/src/multiom/operations/intop/intop_factory_mod.F90 b/src/multiom/operations/intop/intop_factory_mod.F90 index cd79f096e..a4c7034d6 100644 --- a/src/multiom/operations/intop/intop_factory_mod.F90 +++ b/src/multiom/operations/intop/intop_factory_mod.F90 @@ -100,6 +100,7 @@ RECURSIVE FUNCTION MAKE_INTOP( INTOP, CTYPE, CFG, HOOKS ) RESULT(RET) USE :: INTOP_BINARY_OP_MOD, ONLY: INTOP_BINARY_OP_T USE :: INTOP_UNARY_OP_MOD, ONLY: INTOP_UNARY_OP_T USE :: INTOP_CONSTANT_MOD, ONLY: INTOP_CONSTANT_T + USE :: INTOP_ENUM_MOD, ONLY: INTOP_ENUM_T USE :: INTOP_MESSAGE_MOD, ONLY: INTOP_MESSAGE_T USE :: INTOP_PARAMETRIZATION_MOD, ONLY: INTOP_PARAMETRIZATION_T USE :: YAML_CORE_UTILS_MOD, ONLY: YAML_CONFIGURATION_T @@ -219,6 +220,16 @@ RECURSIVE FUNCTION MAKE_INTOP( INTOP, CTYPE, CFG, HOOKS ) RESULT(RET) !> Initialization of the section PP_TRYCALL(ERRFLAG_INITIALIZATION_ERROR) INTOP%INIT( CFG, HOOKS ) + + CASE( 'enum' ) + + + ALLOCATE( INTOP_ENUM_T::INTOP, STAT=ALLOC_STATUS, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STATUS.NE.0, ERRFLAG_ALLOCATION_ERROR ) + + !> Initialization of the section + PP_TRYCALL(ERRFLAG_INITIALIZATION_ERROR) INTOP%INIT( CFG, HOOKS ) + CASE( 'unary-op' ) diff --git a/src/multiom/output-manager/grib_header2multio_mod.F90 b/src/multiom/output-manager/grib_header2multio_mod.F90 index 46f86c39e..7b10038e3 100644 --- a/src/multiom/output-manager/grib_header2multio_mod.F90 +++ b/src/multiom/output-manager/grib_header2multio_mod.F90 @@ -28,6 +28,8 @@ MODULE GRIB_HEADER2MULTIO_MOD USE :: MULTIO_METADATA_MOD, ONLY: MULTIO_METADATA_T USE :: MULTIOM_CACHED_ENCODER_MOD, ONLY: MULTIOM_CACHED_ENCODERS_T USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A + USE :: REPRES_MAP_MOD, ONLY: REPRES_MAP_T + USE :: REPRES_MAP_MOD, ONLY: REPRES_KEY_LENGTH ! Symbols imported from other libraries USE :: MULTIO_API, ONLY: MULTIO_HANDLE @@ -78,6 +80,11 @@ MODULE GRIB_HEADER2MULTIO_MOD !> Metadata object used for the encoding (multio) TYPE(MULTIO_METADATA_T) :: MMD_ + !> Representations map + TYPE(REPRES_MAP_T) :: REPRES_MAP_ + CHARACTER(LEN=REPRES_KEY_LENGTH) :: GG_NAME=REPEAT(' ',REPRES_KEY_LENGTH) + CHARACTER(LEN=REPRES_KEY_LENGTH) :: SH_NAME=REPEAT(' ',REPRES_KEY_LENGTH) + !> Configurations CHARACTER(LEN=1024) :: MULTIO_PLANS_FILE_ = REPEAT(' ',1024) CHARACTER(LEN=1024) :: MAPPING_FILE_ = REPEAT(' ',1024) @@ -147,6 +154,7 @@ MODULE GRIB_HEADER2MULTIO_MOD PROCEDURE, NON_OVERRIDABLE, PASS, PRIVATE :: READ_VERBOSE_FROM_YAML => GRIB_HEADER2MULTIO_READ_VERBOSE_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PASS, PRIVATE :: READ_PROFILE_FROM_YAML => GRIB_HEADER2MULTIO_READ_PROFILE_FROM_YAML PROCEDURE, NON_OVERRIDABLE, PASS, PRIVATE :: READ_REPORT_FROM_YAML => GRIB_HEADER2MULTIO_READ_SAVE_REPORT_FROM_YAML + PROCEDURE, NON_OVERRIDABLE, PASS, PRIVATE :: INIT_GEOMETRY_MAP => GRIB_HEADER2MULTIO_INIT_GEOMETRY_MAP !> @brief Extract mar dictionary and context/parametrization from the ifs data-structures PROCEDURE, NON_OVERRIDABLE, PASS, PRIVATE :: GET_MARS_FROM_ATM => GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM @@ -1364,6 +1372,322 @@ END FUNCTION GRIB_HEADER2MULTIO_READ_SAVE_REPORT_FROM_YAML #undef PP_PROCEDURE_TYPE + +#define PP_PROCEDURE_TYPE 'FUNCTION' +#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_INIT_GEOMETRY_MAP' +PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_INIT_GEOMETRY_MAP( THIS, HOOKS ) RESULT(RET) + + ! Symbols imported from other modules within the project. + USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: HOOKS_MOD, ONLY: HOOKS_T + + USE :: REPRESENTATIONS_MOD, ONLY: REPRES_A + USE :: REPRESENTATIONS_MOD, ONLY: REDUCED_GG_T + USE :: REPRESENTATIONS_MOD, ONLY: REGULAR_GG_T + USE :: REPRESENTATIONS_MOD, ONLY: STRETCHED_ROTATED_SH_T + USE :: REPRESENTATIONS_MOD, ONLY: STRETCHED_SH_T + USE :: REPRESENTATIONS_MOD, ONLY: SH_T + USE :: REPRES_MAP_MOD, ONLY: REPRES_KEY_LENGTH + + ! Symbols imported by the preprocessor for debugging purposes + PP_DEBUG_USE_VARS + + ! Symbols imported by the preprocessor for logging purposes + PP_LOG_USE_VARS + + ! Symbols imported by the preprocessor for tracing purposes + PP_TRACE_USE_VARS + +IMPLICIT NONE + + ! Dummy arguments + CLASS(GRIB_HEADER2MULTIO_OUTPUT_MANAGER_T), INTENT(INOUT) :: THIS + TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS + + !> Function result + INTEGER(KIND=JPIB_K) :: RET + + !> Local variables + CHARACTER(LEN=16) :: CTMP + CHARACTER(LEN=REPRES_KEY_LENGTH) :: KEY + CLASS(REPRES_A), POINTER :: REPRES + INTEGER(KIND=JPIB_K) :: WRITE_STAT + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT + INTEGER(KIND=JPIB_K) :: ALLOC_STAT + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + + !> Error flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INITIALIZE_REPRESENTATION_MAP=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_ALLOCATE_REPRES=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_WRITE=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNEXPECTED_CLASS=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP=5_JPIB_K + + ! Local variables declared by the preprocessor for debugging purposes + PP_DEBUG_DECL_VARS + + ! Local variables declared by the preprocessor for logging purposes + PP_LOG_DECL_VARS + + ! Local variables declared by the preprocessor for tracing purposes + PP_TRACE_DECL_VARS + + ! Trace begin of procedure + PP_TRACE_ENTER_PROCEDURE() + + ! Initialization of good path return value + PP_SET_ERR_SUCCESS( RET ) + + ! Initialize the geometry map + PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_REPRESENTATION_MAP) THIS%REPRES_MAP_%INIT( HOOKS ) + + !> + !> Gridded data + IF ( THIS%MODEL_PAR_%GEO_%NHTYP .GT. 0_JPIB_K ) THEN + + !> Grid is reduced_gg + REPRES => NULL() + ALLOCATE( REDUCED_GG_T::REPRES, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_ALLOCATE_REPRES ) + + !> Generate gg name + CTMP=REPEAT(' ',16) + WRITE(CTMP,'(I6)',IOSTAT=WRITE_STAT) THIS%MODEL_PAR_%GEO_%ILATS/2_JPIB_K + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(THIS%GG_NAME, '(A,A)',IOSTAT=WRITE_STAT) 'O',TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + + !> Fill the general fields on the base data structure + REPRES%DATA_REPRESENTATION_TYPE = 'reduced_gg' + REPRES%NAME = TRIM(ADJUSTL(THIS%GG_NAME)) + + !> Promote to the concrete type to set specific fields + SELECT TYPE( R => REPRES) + CLASS IS (REDUCED_GG_T) + R%TRUNCATE_DEGREES = 1_JPIB_K + R%NUMBER_OF_POINTS_ALONG_A_MERIDIAN = THIS%MODEL_PAR_%GEO_%ILATS + R%NUMBER_OF_PARALLELS_BETWEEN_POLE_AND_EQUATOR = THIS%MODEL_PAR_%GEO_%IDGNH + R%LAT_FIRST_GP_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*THIS%MODEL_PAR_%GEO_%ZNLAT + R%LON_FIRST_GP_DEG = 0.0_JPRD_K + R%LAT_LAST_GP_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*THIS%MODEL_PAR_%GEO_%ZSLAT + R%LON_LAST_GP_DEG = 360._JPRD_K-360._JPRD_K/REAL(THIS%MODEL_PAR_%GEO_%ILONS,JPRD_K) + R%TO_BE_DEALLOCATED = .FALSE. + R%PL => THIS%MODEL_PAR_%GEO_%ILOENG(1:THIS%MODEL_PAR_%GEO_%ILATS) + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNEXPECTED_CLASS ) + END SELECT + + !> Add the representation to the map + KEY=REPEAT(' ',REPRES_KEY_LENGTH) + KEY='gg_'//TRIM(ADJUSTL(THIS%GG_NAME)) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) THIS%REPRES_MAP_%PUSH( KEY, REPRES, .TRUE., HOOKS ) + + ELSE + ! Grid is regular_gg (full) + REPRES => NULL() + ALLOCATE( REGULAR_GG_T::REPRES, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_ALLOCATE_REPRES ) + + !> Generate gg name + CTMP=REPEAT(' ',16) + WRITE(CTMP,'(I6)',IOSTAT=WRITE_STAT) THIS%MODEL_PAR_%GEO_%IDGNH + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(THIS%GG_NAME, '(A,A)',IOSTAT=WRITE_STAT) 'F',TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + + !> Fill the general fields on the base data structure + REPRES%DATA_REPRESENTATION_TYPE = 'regular_gg' + REPRES%NAME = TRIM(ADJUSTL(THIS%GG_NAME)) + + !> Promote to the concrete type to set specific fields + SELECT TYPE( R => REPRES) + CLASS IS (REGULAR_GG_T) + R%TRUNCATE_DEGREES = 1_JPIB_K + R%NUMBER_OF_POINTS_ALONG_A_MERIDIAN = THIS%MODEL_PAR_%GEO_%ILATS + R%NUMBER_OF_POINTS_ALONG_A_PARALLEL = THIS%MODEL_PAR_%GEO_%ILONS + R%NUMBER_OF_PARALLELS_BETWEEN_POLE_AND_EQUATOR = THIS%MODEL_PAR_%GEO_%IDGNH + R%LAT_FIRST_GP_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*THIS%MODEL_PAR_%GEO_%ZNLAT + R%LON_FIRST_GP_DEG = 0.0_JPRD_K + R%LAT_LAST_GP_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*THIS%MODEL_PAR_%GEO_%ZSLAT + R%LON_LAST_GP_DEG = 360._JPRD_K-360._JPRD_K/REAL(THIS%MODEL_PAR_%GEO_%ILONS,JPRD_K) + R%IDIR_INC = 360.0_JPRD_K/REAL(THIS%MODEL_PAR_%GEO_%ILONS,JPRD_K) + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNEXPECTED_CLASS ) + END SELECT + + !> Add the representation to the map + KEY=REPEAT(' ',REPRES_KEY_LENGTH) + KEY='gg_'//TRIM(ADJUSTL(THIS%GG_NAME)) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) THIS%REPRES_MAP_%PUSH( KEY, REPRES, .TRUE., HOOKS ) + ENDIF + + + !> + !> Spherical harmonics + IF ( THIS%MODEL_PAR_%GEO_%NSTTYP .GE. 2_JPIB_K ) THEN + ! grid is stretched rotated spherical harmonics + REPRES => NULL() + ALLOCATE( STRETCHED_ROTATED_SH_T::REPRES, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_ALLOCATE_REPRES ) + + !> Generate sh name + CTMP=REPEAT(' ',16) + WRITE(CTMP,'(I16)',IOSTAT=WRITE_STAT) THIS%MODEL_PAR_%GEO_%ISMAX + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(THIS%SH_NAME, '(A,A)',IOSTAT=WRITE_STAT) 'SRS',TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + + !> Fill the general fields on the base data structure + REPRES%DATA_REPRESENTATION_TYPE = 'stretched_rotated_sh' + REPRES%NAME = TRIM(ADJUSTL(THIS%SH_NAME)) + + !> Promote to the concrete type to set specific fields + SELECT TYPE( R => REPRES) + CLASS IS (STRETCHED_ROTATED_SH_T) + R%LAT_STRET_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*ASIN(REAL(THIS%MODEL_PAR_%GEO_%RMUCEN,JPRD_K)) + R%LON_STRET_DEG = 180._JPRD_K/(2.0_JPRD_K*ASIN(1.0_JPRD_K))*REAL(THIS%MODEL_PAR_%GEO_%RLOCEN,JPRD_K) + R%STRETCH_FACTOR = THIS%MODEL_PAR_%GEO_%RSTRET + R%PENTAGONAL_RESOLUTIONS_PAR_J = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_K = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_M = THIS%MODEL_PAR_%GEO_%ISMAX + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNEXPECTED_CLASS ) + END SELECT + + !> Add the representation to the map + KEY=REPEAT(' ',REPRES_KEY_LENGTH) + KEY='sh_'//TRIM(ADJUSTL(THIS%SH_NAME)) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) THIS%REPRES_MAP_%PUSH( KEY, REPRES, .TRUE., HOOKS ) + + ELSEIF ( ABS(THIS%MODEL_PAR_%GEO_%RSTRET-1.0_JPRD_K) .GE. 1.0E-14_JPRD_K ) THEN + ! grid is stretched spherical harmonics + REPRES => NULL() + ALLOCATE( STRETCHED_ROTATED_SH_T::REPRES, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_ALLOCATE_REPRES ) + + !> Generate sh name + CTMP=REPEAT(' ',16) + WRITE(CTMP,'(I16)',IOSTAT=WRITE_STAT) THIS%MODEL_PAR_%GEO_%ISMAX + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(THIS%SH_NAME, '(A,A)',IOSTAT=WRITE_STAT) 'SS',TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + + !> Fill the general fields on the base data structure + REPRES%DATA_REPRESENTATION_TYPE = 'stretched_sh' + REPRES%NAME = TRIM(ADJUSTL(THIS%SH_NAME)) + + !> Promote to the concrete type to set specific fields + SELECT TYPE( R => REPRES) + CLASS IS (STRETCHED_ROTATED_SH_T) + R%STRETCH_FACTOR = THIS%MODEL_PAR_%GEO_%RSTRET + R%PENTAGONAL_RESOLUTIONS_PAR_J = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_K = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_M = THIS%MODEL_PAR_%GEO_%ISMAX + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNEXPECTED_CLASS ) + END SELECT + + !> Add the representation to the map + KEY=REPEAT(' ',REPRES_KEY_LENGTH) + KEY='sh_'//TRIM(ADJUSTL(THIS%SH_NAME)) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) THIS%REPRES_MAP_%PUSH( KEY, REPRES, .TRUE., HOOKS ) + + ELSE + ! grid is spherical harmonics + ! grid is stretched spherical harmonics + ! grid is stretched rotated spherical harmonics + REPRES => NULL() + ALLOCATE( STRETCHED_ROTATED_SH_T::REPRES, STAT=ALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( ALLOC_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_ALLOCATE_REPRES ) + + !> Generate sh name + CTMP=REPEAT(' ',16) + WRITE(CTMP,'(I16)',IOSTAT=WRITE_STAT) THIS%MODEL_PAR_%GEO_%ISMAX + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + WRITE(THIS%SH_NAME, '(A,A)',IOSTAT=WRITE_STAT) 'S',TRIM(ADJUSTL(CTMP)) + PP_DEBUG_CRITICAL_COND_THROW( WRITE_STAT.NE.0_JPIB_K, ERRFLAG_UNABLE_TO_WRITE ) + + !> Fill the general fields on the base data structure + REPRES%DATA_REPRESENTATION_TYPE = 'sh' + REPRES%NAME = TRIM(ADJUSTL(THIS%SH_NAME)) + + !> Promote to the concrete type to set specific fields + SELECT TYPE( R => REPRES) + CLASS IS (STRETCHED_ROTATED_SH_T) + R%PENTAGONAL_RESOLUTIONS_PAR_J = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_K = THIS%MODEL_PAR_%GEO_%ISMAX + R%PENTAGONAL_RESOLUTIONS_PAR_M = THIS%MODEL_PAR_%GEO_%ISMAX + CLASS DEFAULT + PP_DEBUG_CRITICAL_THROW( ERRFLAG_UNEXPECTED_CLASS ) + END SELECT + + !> Add the representation to the map + KEY=REPEAT(' ',REPRES_KEY_LENGTH) + KEY='sh_'//TRIM(ADJUSTL(THIS%SH_NAME)) + PP_TRYCALL(ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) THIS%REPRES_MAP_%PUSH( KEY, REPRES, .TRUE., HOOKS ) + + ENDIF + + ! Trace end of procedure (on success) + PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() + + ! Exit point (on success) + RETURN + +! Error handler +PP_ERROR_HANDLER + + ! Initialization of bad path return value + PP_SET_ERR_FAILURE( RET ) + +#if defined( PP_DEBUG_ENABLE_ERROR_HANDLING ) +!$omp critical(ERROR_HANDLER) + + BLOCK + + ! Error handling variables + PP_DEBUG_PUSH_FRAME() + + ! HAndle different errors + SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_INITIALIZE_REPRESENTATION_MAP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to initialize the representation map' ) + CASE (ERRFLAG_UNABLE_TO_ALLOCATE_REPRES) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to allocate the representation' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: "'//TRIM(ADJUSTL(ERRMSG))//'"' ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + ENDIF + CASE (ERRFLAG_UNABLE_TO_WRITE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to write to the string' ) + CASE (ERRFLAG_UNEXPECTED_CLASS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unexpected class' ) + CASE (ERRFLAG_UNABLE_TO_PUSH_TO_REPRESENTATION_MAP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to push the representation to the map' ) + CASE DEFAULT + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) + END SELECT + + ! Trace end of procedure (on error) + PP_TRACE_EXIT_PROCEDURE_ON_ERROR() + + ! Write the error message and stop the program + PP_DEBUG_ABORT + + END BLOCK + +!$omp end critical(ERROR_HANDLER) +#endif + + ! Exit point on error + RETURN + +END FUNCTION GRIB_HEADER2MULTIO_INIT_GEOMETRY_MAP +#undef PP_PROCEDURE_NAME +#undef PP_PROCEDURE_TYPE + + #define PP_PROCEDURE_TYPE 'FUNCTION' #define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM' PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, PAR, HOOKS ) RESULT(RET) @@ -1386,6 +1710,8 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ENSEMBLE USE :: IFS2MARS_MOD, ONLY: ATM2MARS_SET_PARAM USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_DATETIME + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_GEOMETRY + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_IDENTIFICATION ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1401,8 +1727,8 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, ! Dummy arguments CLASS(GRIB_HEADER2MULTIO_OUTPUT_MANAGER_T), INTENT(INOUT) :: THIS TYPE(OM_ATM_MSG_T), INTENT(IN) :: YDMSG - TYPE(FORTRAN_MESSAGE_T), INTENT(OUT) :: MSG - TYPE(PARAMETRIZATION_T), INTENT(OUT) :: PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result @@ -1424,6 +1750,8 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ENSEMBLE=9_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PARAM=10_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_DATETIME=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_GEOMETRY=12_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_IDENTIFICATION=13_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1441,6 +1769,7 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, PP_SET_ERR_SUCCESS( RET ) ! Extract mars and context from message and parametrization + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_IDENTIFICATION) IFS2MARS_SET_IDENTIFICATION( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ORIGIN) IFS2MARS_SET_ORIGIN ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_STREAM) IFS2MARS_SET_STREAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_TYPE) IFS2MARS_SET_TYPE ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) @@ -1453,6 +1782,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ENSEMBLE) IFS2MARS_SET_ENSEMBLE( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PARAM) ATM2MARS_SET_PARAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_DATETIME) IFS2MARS_SET_DATETIME( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_GEOMETRY) IFS2MARS_SET_GEOMETRY( YDMSG, THIS%MODEL_PAR_, & +& THIS%GG_NAME, THIS%SH_NAME, THIS%REPRES_MAP_, & +& MSG, PAR, HOOKS ) ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1499,7 +1831,11 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM( THIS, YDMSG, MSG, CASE (ERRFLAG_UNABLE_TO_SET_PARAM) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the param' ) CASE (ERRFLAG_UNABLE_TO_SET_DATETIME) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the time' ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the datetime' ) + CASE (ERRFLAG_UNABLE_TO_SET_GEOMETRY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the geometry' ) + CASE (ERRFLAG_UNABLE_TO_SET_IDENTIFICATION) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the identification' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -1524,17 +1860,28 @@ END FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_ATM #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_READ_SINK_DP' -PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & -& NUNDEF, XUNDEF, MD, VALUES_DP, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM' +PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, PAR, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K - USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A + USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T USE :: HOOKS_MOD, ONLY: HOOKS_T + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ORIGIN + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_STREAM + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_TYPE + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_CLASS + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_EXPVER + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_PACKING + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ANALYSIS + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ENSEMBLE + USE :: IFS2MARS_MOD, ONLY: WAM2MARS_SET_PARAM + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_DATETIME + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_GEOMETRY + USE :: IFS2MARS_MOD, ONLY: WAM2MARS_SET_DIRFREQ + USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_IDENTIFICATION ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1549,17 +1896,32 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & ! Dummy arguments CLASS(GRIB_HEADER2MULTIO_OUTPUT_MANAGER_T), INTENT(INOUT) :: THIS - TYPE(FORTRAN_MESSAGE_T), INTENT(IN) :: MSG - TYPE(PARAMETRIZATION_T), INTENT(IN) :: PAR - INTEGER(KIND=JPIB_K), INTENT(IN) :: NUNDEF - REAL(KIND=JPRD_K), INTENT(IN) :: XUNDEF - CLASS(METADATA_BASE_A), POINTER, INTENT(IN) :: MD - REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUES_DP + TYPE(OM_WAM_MSG_T), INTENT(IN) :: YDMSG + TYPE(FORTRAN_MESSAGE_T), INTENT(INOUT) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(INOUT) :: PAR TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET + ! Local variables + LOGICAL, DIMENSION(5) :: CONDITIONS + + ! Error Flags + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ORIGIN=0_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_STREAM=1_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_TYPE=2_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_CLASS=3_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_EXPVER=4_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PACKING=5_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ANALYSIS=6_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ENSEMBLE=7_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PARAM=8_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_DATETIME=9_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_GEOMETRY=10_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_DIRFREQ=11_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_IDENTIFICATION=12_JPIB_K + ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1575,6 +1937,22 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) + ! Extract mars and context from message and parametrization + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_IDENTIFICATION) IFS2MARS_SET_IDENTIFICATION( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ORIGIN) IFS2MARS_SET_ORIGIN ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_STREAM) IFS2MARS_SET_STREAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_TYPE) IFS2MARS_SET_TYPE ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_CLASS) IFS2MARS_SET_CLASS ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_EXPVER) IFS2MARS_SET_EXPVER ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PACKING) IFS2MARS_SET_PACKING ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ANALYSIS) IFS2MARS_SET_ANALYSIS( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ENSEMBLE) IFS2MARS_SET_ENSEMBLE( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PARAM) WAM2MARS_SET_PARAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_DATETIME) IFS2MARS_SET_DATETIME( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_GEOMETRY) IFS2MARS_SET_GEOMETRY( YDMSG, THIS%MODEL_PAR_, & +& THIS%GG_NAME, THIS%SH_NAME, THIS%REPRES_MAP_, & +& MSG, PAR, HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_GEOMETRY) WAM2MARS_SET_DIRFREQ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1598,6 +1976,32 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & ! HAndle different errors SELECT CASE(ERRIDX) + CASE (ERRFLAG_UNABLE_TO_SET_ORIGIN) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the origin' ) + CASE (ERRFLAG_UNABLE_TO_SET_STREAM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the stream' ) + CASE (ERRFLAG_UNABLE_TO_SET_TYPE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the type' ) + CASE (ERRFLAG_UNABLE_TO_SET_CLASS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the class' ) + CASE (ERRFLAG_UNABLE_TO_SET_EXPVER) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the expver' ) + CASE (ERRFLAG_UNABLE_TO_SET_PACKING) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the packing' ) + CASE (ERRFLAG_UNABLE_TO_SET_ANALYSIS) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the analysis' ) + CASE (ERRFLAG_UNABLE_TO_SET_ENSEMBLE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the ensemble' ) + CASE (ERRFLAG_UNABLE_TO_SET_PARAM) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the param' ) + CASE (ERRFLAG_UNABLE_TO_SET_DATETIME) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the datetime' ) + CASE (ERRFLAG_UNABLE_TO_SET_GEOMETRY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the geometry' ) + CASE (ERRFLAG_UNABLE_TO_SET_DIRFREQ) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the dirfreq' ) + CASE (ERRFLAG_UNABLE_TO_SET_IDENTIFICATION) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the identification' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -1616,19 +2020,18 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & ! Exit point on error RETURN -END FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP +END FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_READ_SINK_SP' -PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP( THIS, MSG, PAR, & -& NUNDEF, XUNDEF, MD, VALUES_SP, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_READ_SINK_DP' +PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP( THIS, MSG, PAR, & +& NUNDEF, XUNDEF, MD, VALUES_DP, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: DATAKINDS_DEF_MOD, ONLY: JPRM_K USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T @@ -1653,7 +2056,7 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP( THIS, MSG, PAR, & INTEGER(KIND=JPIB_K), INTENT(IN) :: NUNDEF REAL(KIND=JPRD_K), INTENT(IN) :: XUNDEF CLASS(METADATA_BASE_A), POINTER, INTENT(IN) :: MD - REAL(KIND=JPRM_K), DIMENSION(:), INTENT(IN) :: VALUES_SP + REAL(KIND=JPRD_K), DIMENSION(:), INTENT(IN) :: VALUES_DP TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result @@ -1715,34 +2118,24 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP( THIS, MSG, PAR, & ! Exit point on error RETURN -END FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP +END FUNCTION GRIB_HEADER2MULTIO_READ_SINK_DP #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE #define PP_PROCEDURE_TYPE 'FUNCTION' -#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM' -PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, PAR, HOOKS ) RESULT(RET) +#define PP_PROCEDURE_NAME 'GRIB_HEADER2MULTIO_READ_SINK_SP' +PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP( THIS, MSG, PAR, & +& NUNDEF, XUNDEF, MD, VALUES_SP, HOOKS ) RESULT(RET) ! Symbols imported from other modules within the project. USE :: DATAKINDS_DEF_MOD, ONLY: JPIB_K - USE :: IFS_MSG_MOD, ONLY: OM_WAM_MSG_T + USE :: DATAKINDS_DEF_MOD, ONLY: JPRM_K + USE :: DATAKINDS_DEF_MOD, ONLY: JPRD_K + USE :: METADATA_BASE_MOD, ONLY: METADATA_BASE_A USE :: FORTRAN_MESSAGE_MOD, ONLY: FORTRAN_MESSAGE_T USE :: PARAMETRIZATION_MOD, ONLY: PARAMETRIZATION_T USE :: HOOKS_MOD, ONLY: HOOKS_T - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ORIGIN - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_STREAM - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_TYPE - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_CLASS - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_EXPVER - ! USE :: IFS2MARS_MOD, ONLY: ATM2MARS_SET_LEVTYPE - ! USE :: IFS2MARS_MOD, ONLY: ATM2MARS_SET_LEVELIST - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_PACKING - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ANALYSIS - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_ENSEMBLE - ! USE :: IFS2MARS_MOD, ONLY: ATM2MARS_SET_PARAM - USE :: IFS2MARS_MOD, ONLY: IFS2MARS_SET_DATETIME - ! Symbols imported by the preprocessor for debugging purposes PP_DEBUG_USE_VARS @@ -1757,31 +2150,17 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, ! Dummy arguments CLASS(GRIB_HEADER2MULTIO_OUTPUT_MANAGER_T), INTENT(INOUT) :: THIS - TYPE(OM_WAM_MSG_T), INTENT(IN) :: YDMSG - TYPE(FORTRAN_MESSAGE_T), INTENT(OUT) :: MSG - TYPE(PARAMETRIZATION_T), INTENT(OUT) :: PAR + TYPE(FORTRAN_MESSAGE_T), INTENT(IN) :: MSG + TYPE(PARAMETRIZATION_T), INTENT(IN) :: PAR + INTEGER(KIND=JPIB_K), INTENT(IN) :: NUNDEF + REAL(KIND=JPRD_K), INTENT(IN) :: XUNDEF + CLASS(METADATA_BASE_A), POINTER, INTENT(IN) :: MD + REAL(KIND=JPRM_K), DIMENSION(:), INTENT(IN) :: VALUES_SP TYPE(HOOKS_T), INTENT(INOUT) :: HOOKS !> Function result INTEGER(KIND=JPIB_K) :: RET - ! Local variables - LOGICAL, DIMENSION(5) :: CONDITIONS - - ! Error Flags - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ORIGIN=0_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_STREAM=1_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_TYPE=2_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_CLASS=3_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_EXPVER=4_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_LEVTYPE=5_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_LEVELIST=6_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PACKING=7_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ANALYSIS=8_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_ENSEMBLE=9_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_PARAM=10_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_SET_DATETIME=11_JPIB_K - ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -1797,19 +2176,6 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, ! Initialization of good path return value PP_SET_ERR_SUCCESS( RET ) - ! Extract mars and context from message and parametrization - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ORIGIN) IFS2MARS_SET_ORIGIN ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_STREAM) IFS2MARS_SET_STREAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_TYPE) IFS2MARS_SET_TYPE ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_CLASS) IFS2MARS_SET_CLASS ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_EXPVER) IFS2MARS_SET_EXPVER ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_LEVTYPE) ATM2MARS_SET_LEVTYPE ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_LEVELIST) ATM2MARS_SET_LEVELIST( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PACKING) IFS2MARS_SET_PACKING ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ANALYSIS) IFS2MARS_SET_ANALYSIS( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_ENSEMBLE) IFS2MARS_SET_ENSEMBLE( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - ! PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_PARAM) ATM2MARS_SET_PARAM ( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) - PP_TRYCALL(ERRFLAG_UNABLE_TO_SET_DATETIME) IFS2MARS_SET_DATETIME( YDMSG, THIS%MODEL_PAR_, MSG, PAR, HOOKS ) ! Trace end of procedure (on success) PP_TRACE_EXIT_PROCEDURE_ON_SUCCESS() @@ -1833,30 +2199,6 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, ! HAndle different errors SELECT CASE(ERRIDX) - CASE (ERRFLAG_UNABLE_TO_SET_ORIGIN) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the origin' ) - CASE (ERRFLAG_UNABLE_TO_SET_STREAM) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the stream' ) - CASE (ERRFLAG_UNABLE_TO_SET_TYPE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the type' ) - CASE (ERRFLAG_UNABLE_TO_SET_CLASS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the class' ) - CASE (ERRFLAG_UNABLE_TO_SET_EXPVER) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the expver' ) - CASE (ERRFLAG_UNABLE_TO_SET_LEVTYPE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the levtype' ) - CASE (ERRFLAG_UNABLE_TO_SET_LEVELIST) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the levlist' ) - CASE (ERRFLAG_UNABLE_TO_SET_PACKING) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the packing' ) - CASE (ERRFLAG_UNABLE_TO_SET_ANALYSIS) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the analysis' ) - CASE (ERRFLAG_UNABLE_TO_SET_ENSEMBLE) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the ensemble' ) - CASE (ERRFLAG_UNABLE_TO_SET_PARAM) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the param' ) - CASE (ERRFLAG_UNABLE_TO_SET_DATETIME) - PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to set the time' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -1875,7 +2217,7 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM( THIS, YDMSG, MSG, ! Exit point on error RETURN -END FUNCTION GRIB_HEADER2MULTIO_GET_MARS_FROM_WAM +END FUNCTION GRIB_HEADER2MULTIO_READ_SINK_SP #undef PP_PROCEDURE_NAME #undef PP_PROCEDURE_TYPE @@ -2002,6 +2344,8 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_SETUP( THIS, YAMLFNAME, PROCESSOR_TOP INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_GET_NUM_THREADS=29_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_LOADING_LOCAL_SAMPLE=30_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_INITIALIZE_ENCODER=31_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INT_GEOMETRY=32_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_PRINT_GEOMETRY_MAP=33_JPIB_K ! Local variables declared by the preprocessor for debugging purposes @@ -2081,6 +2425,13 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_SETUP( THIS, YAMLFNAME, PROCESSOR_TOP PP_TRYCALL(ERRFLAG_UNABLE_TO_LOG_PARAMETERS) PAR_PRINT( MODEL_PARAMS, THIS%LOG_UNIT_, HOOKS ) ENDIF + ! Initialize the geometry map + PP_TRYCALL(ERRFLAG_UNABLE_TO_INT_GEOMETRY) THIS%INIT_GEOMETRY_MAP( HOOKS ) + + ! Print the geoemtry map + IF ( THIS%VERBOSE_ ) THEN + PP_TRYCALL(ERRFLAG_PRINT_GEOMETRY_MAP) THIS%REPRES_MAP_%LIST( 6_JPIB_K, 'Geometry map: ', HOOKS ) + ENDIF !> Open the configuration file PP_TRYCALL(ERRFLAG_LOADING_LOCAL_SAMPLE) MAKE_METADATA( THIS%METADATA_, 'log', 'sample', HOOKS ) @@ -2157,6 +2508,10 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_SETUP( THIS, YAMLFNAME, PROCESSOR_TOP PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to load the local sample' ) CASE (ERRFLAG_UNABLE_INITIALIZE_ENCODER) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to initialize the encoder' ) + CASE (ERRFLAG_UNABLE_TO_INT_GEOMETRY) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to initialize the geometry map' ) + CASE (ERRFLAG_PRINT_GEOMETRY_MAP) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to print the geometry map' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -2234,7 +2589,6 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, TYPE(FORTRAN_MESSAGE_T) :: OUT_MSG TYPE(PARAMETRIZATION_T) :: OUT_PAR TYPE(METADATA_LIST_T) :: METADATA_LIST - INTEGER(KIND=JPIB_K) :: DEALLOC_STAT CLASS(METADATA_BASE_A), POINTER :: MD CHARACTER(LEN=256) :: MAPPING_TAG CHARACTER(LEN=256) :: MAPPING_NAME @@ -2242,6 +2596,7 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, CHARACTER(LEN=256) :: ENCODER_NAME CHARACTER(LEN=:), ALLOCATABLE :: JSON CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT ! Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_LOG_TIME=1_JPIB_K @@ -2257,9 +2612,11 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_CHECK_LIST=11_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_MSG=12_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_PAR=13_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=14_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON=15_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=16_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_MSG=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_PAR=15_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=16_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON=17_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=18_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2288,17 +2645,19 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, ENDIF ! Write the message + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_MSG) IN_MSG%INIT( HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_PAR) IN_PAR%INIT( HOOKS ) PP_TRYCALL(ERRFLAG_CONMVERT_TO_MARS) THIS%GET_MARS_FROM_ATM( YDMSG, IN_MSG, IN_PAR, HOOKS ) PP_TRYCALL(ERRFLAG_MARS_TO_JSON) IN_MSG%TO_JSON( JSON, HOOKS ) IF ( ALLOCATED(JSON) ) THEN - WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + WRITE(*,'(A,A)') ' * ORIGINAL - MARS to JSON: ', JSON DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) END IF -#if 0 + !> Initialize the metadata list PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_METADATA_LIST) METADATA_LIST%INIT( HOOKS ) @@ -2313,9 +2672,21 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, PP_TRYCALL(ERRFLAG_UNABLE_TO_POP_FROM_LIST) METADATA_LIST%POP( OUT_MSG, OUT_PAR, & & MAPPING_TAG, MAPPING_NAME, ENCODER_TAG, ENCODER_NAME, MD, HOOKS ) + !> Print Mapped message + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) OUT_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') ' * MAPPED - MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ELSE + WRITE(*,*) ' * MAPPED - MARS to JSON: ', 'NO JSON' + END IF + +#if 0 !> Sink the message PP_TRYCALL(ERRFLAG_WRITE_MSG_ATM) THIS%SINK_DP( OUT_MSG, OUT_PAR, YDMSG%NUNDF_, YDMSG%XUNDF_, MD, VALUES_DP, HOOKS ) +#endif !> Free the encoded metadata PP_TRYCALL(ERRFLAG_UNABLE_DEALLOCATE_METADATA) DESTROY_METADATA( MD, HOOKS ) @@ -2327,7 +2698,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, PP_TRYCALL(ERRFLAG_UNABLE_CHECK_LIST) METADATA_LIST%IS_EMPTY( IS_EMPTY, HOOKS ) ENDDO -#endif + + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_PAR%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) !> Free the message/parametrization PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%FREE( HOOKS ) @@ -2387,6 +2760,16 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_DP( THIS, YDMSG, VALUES_DP, PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ADJUSTL(ERRMSG)) ) DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) END IF + CASE (ERRFLAG_UNABLE_TO_FREE_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the message' ) + CASE (ERRFLAG_UNABLE_TO_FREE_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the parametrization' ) + CASE (ERRFLAG_UNABLE_TO_INIT_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the message' ) + CASE (ERRFLAG_UNABLE_TO_INIT_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the parametrization' ) + CASE (ERRFLAG_METADATA_LIST_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the metadata list' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -2470,6 +2853,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, CHARACTER(LEN=256) :: MAPPING_NAME CHARACTER(LEN=256) :: ENCODER_TAG CHARACTER(LEN=256) :: ENCODER_NAME + CHARACTER(LEN=:), ALLOCATABLE :: JSON + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT ! Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_LOG_TIME=1_JPIB_K @@ -2485,7 +2871,11 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_CHECK_LIST=11_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_MSG=12_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_PAR=13_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_MSG=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_PAR=15_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=16_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON=17_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=18_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2513,11 +2903,20 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT_MSG) MSG_PRINT_ATM( YDMSG, THIS%LOG_UNIT_, HOOKS ) ENDIF + ! Write the message + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_MSG) IN_MSG%INIT( HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_PAR) IN_PAR%INIT( HOOKS ) PP_TRYCALL(ERRFLAG_CONMVERT_TO_MARS) THIS%GET_MARS_FROM_ATM( YDMSG, IN_MSG, IN_PAR, HOOKS ) -#if 0 + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) IN_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + END IF + !> Initialize the metadata list PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_METADATA_LIST) METADATA_LIST%INIT( HOOKS ) @@ -2532,9 +2931,20 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_TO_POP_FROM_LIST) METADATA_LIST%POP( OUT_MSG, OUT_PAR, & & MAPPING_TAG, MAPPING_NAME, ENCODER_TAG, ENCODER_NAME, MD, HOOKS ) + !> Print Mapped message + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) OUT_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ELSE + WRITE(*,*) ' * MAPPED - MARS to JSON: ', 'NO JSON' + END IF + +#if 0 !> Sink the message PP_TRYCALL(ERRFLAG_WRITE_MSG_ATM) THIS%SINK_SP( OUT_MSG, OUT_PAR, YDMSG%NUNDF_, YDMSG%XUNDF_, MD, VALUES_SP, HOOKS ) - +#endif !> Free the encoded metadata PP_TRYCALL(ERRFLAG_UNABLE_DEALLOCATE_METADATA) DESTROY_METADATA( MD, HOOKS ) @@ -2546,7 +2956,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_CHECK_LIST) METADATA_LIST%IS_EMPTY( IS_EMPTY, HOOKS ) ENDDO -#endif + + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_PAR%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) !> Free the message/parametrization PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%FREE( HOOKS ) @@ -2598,6 +3010,24 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_ATM_SP( THIS, YDMSG, VALUES_SP, PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to write the message' ) CASE (ERRFLAG_UNABLE_DEALLOCATE_METADATA) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate the metadata' ) + CASE (ERRFLAG_MARS_TO_JSON) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert MARS to JSON' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate json' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + END IF + CASE (ERRFLAG_UNABLE_TO_FREE_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the message' ) + CASE (ERRFLAG_UNABLE_TO_FREE_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the parametrization' ) + CASE (ERRFLAG_UNABLE_TO_INIT_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the message' ) + CASE (ERRFLAG_UNABLE_TO_INIT_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the parametrization' ) + CASE (ERRFLAG_METADATA_LIST_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the metadata list' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -2681,6 +3111,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, CHARACTER(LEN=256) :: MAPPING_NAME CHARACTER(LEN=256) :: ENCODER_TAG CHARACTER(LEN=256) :: ENCODER_NAME + CHARACTER(LEN=:), ALLOCATABLE :: JSON + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT ! Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_LOG_TIME=1_JPIB_K @@ -2696,7 +3129,11 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_CHECK_LIST=11_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_MSG=12_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_PAR=13_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_MSG=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_PAR=15_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=16_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON=17_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=18_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2724,11 +3161,20 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT_MSG) MSG_PRINT_WAM( YDMSG, THIS%LOG_UNIT_, HOOKS ) ENDIF + ! Write the message + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_MSG) IN_MSG%INIT( HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_PAR) IN_PAR%INIT( HOOKS ) PP_TRYCALL(ERRFLAG_CONMVERT_TO_MARS) THIS%GET_MARS_FROM_WAM( YDMSG, IN_MSG, IN_PAR, HOOKS ) -#if 0 + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) IN_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + END IF + !> Initialize the metadata list PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_METADATA_LIST) METADATA_LIST%INIT( HOOKS ) @@ -2743,9 +3189,21 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, PP_TRYCALL(ERRFLAG_UNABLE_TO_POP_FROM_LIST) METADATA_LIST%POP( OUT_MSG, OUT_PAR, & & MAPPING_TAG, MAPPING_NAME, ENCODER_TAG, ENCODER_NAME, MD, HOOKS ) + !> Print Mapped message + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) OUT_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ELSE + WRITE(*,*) ' * MAPPED - MARS to JSON: ', 'NO JSON' + END IF + +#if 0 !> Sink the message PP_TRYCALL(ERRFLAG_WRITE_MSG_WAM) THIS%SINK_DP( OUT_MSG, OUT_PAR, YDMSG%NUNDF_, YDMSG%XUNDF_, MD, VALUES_DP, HOOKS ) +#endif !> Free the encoded metadata PP_TRYCALL(ERRFLAG_UNABLE_DEALLOCATE_METADATA) DESTROY_METADATA( MD, HOOKS ) @@ -2757,7 +3215,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, PP_TRYCALL(ERRFLAG_UNABLE_CHECK_LIST) METADATA_LIST%IS_EMPTY( IS_EMPTY, HOOKS ) ENDDO -#endif + + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_PAR%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) !> Free the message/parametrization PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%FREE( HOOKS ) @@ -2809,6 +3269,24 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_DP( THIS, YDMSG, VALUES_DP, PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to write the message' ) CASE (ERRFLAG_UNABLE_DEALLOCATE_METADATA) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate the metadata' ) + CASE (ERRFLAG_MARS_TO_JSON) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert MARS to JSON' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate json' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + END IF + CASE (ERRFLAG_UNABLE_TO_FREE_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the message' ) + CASE (ERRFLAG_UNABLE_TO_FREE_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the parametrization' ) + CASE (ERRFLAG_UNABLE_TO_INIT_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the message' ) + CASE (ERRFLAG_UNABLE_TO_INIT_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the parametrization' ) + CASE (ERRFLAG_METADATA_LIST_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the metadata list' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT @@ -2897,6 +3375,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, CHARACTER(LEN=256) :: MAPPING_NAME CHARACTER(LEN=256) :: ENCODER_TAG CHARACTER(LEN=256) :: ENCODER_NAME + CHARACTER(LEN=:), ALLOCATABLE :: JSON + CHARACTER(LEN=:), ALLOCATABLE :: ERRMSG + INTEGER(KIND=JPIB_K) :: DEALLOC_STAT ! Error flags INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_LOG_TIME=1_JPIB_K @@ -2912,7 +3393,11 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_CHECK_LIST=11_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_MSG=12_JPIB_K INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_FREE_PAR=13_JPIB_K - INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_MSG=14_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_INIT_PAR=15_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_METADATA_LIST_FREE=16_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_MARS_TO_JSON=17_JPIB_K + INTEGER(KIND=JPIB_K), PARAMETER :: ERRFLAG_UNABLE_TO_DEALLOCATE=18_JPIB_K ! Local variables declared by the preprocessor for debugging purposes PP_DEBUG_DECL_VARS @@ -2940,11 +3425,20 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_TO_PRINT_MSG) MSG_PRINT_WAM( YDMSG, THIS%LOG_UNIT_, HOOKS ) ENDIF + ! Write the message + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_MSG) IN_MSG%INIT( HOOKS ) + PP_TRYCALL(ERRFLAG_UNABLE_TO_INIT_PAR) IN_PAR%INIT( HOOKS ) PP_TRYCALL(ERRFLAG_CONMVERT_TO_MARS) THIS%GET_MARS_FROM_WAM( YDMSG, IN_MSG, IN_PAR, HOOKS ) -#if 0 + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) IN_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + END IF + !> Initialize the metadata list PP_TRYCALL(ERRFLAG_UNABLE_TO_INITIALIZE_METADATA_LIST) METADATA_LIST%INIT( HOOKS ) @@ -2959,8 +3453,20 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_TO_POP_FROM_LIST) METADATA_LIST%POP( OUT_MSG, OUT_PAR, & & MAPPING_TAG, MAPPING_NAME, ENCODER_TAG, ENCODER_NAME, MD, HOOKS ) + !> Print Mapped message + PP_TRYCALL(ERRFLAG_MARS_TO_JSON) OUT_MSG%TO_JSON( JSON, HOOKS ) + IF ( ALLOCATED(JSON) ) THEN + WRITE(*,'(A,A)') 'MARS to JSON: ', JSON + DEALLOCATE( JSON, STAT=DEALLOC_STAT, ERRMSG=ERRMSG ) + PP_DEBUG_CRITICAL_COND_THROW( DEALLOC_STAT .NE. 0, ERRFLAG_UNABLE_TO_DEALLOCATE ) + ELSE + WRITE(*,*) ' * MAPPED - MARS to JSON: ', 'NO JSON' + END IF + +#if 0 !> Sink the message PP_TRYCALL(ERRFLAG_WRITE_MSG_WAM) THIS%SINK_SP( OUT_MSG, OUT_PAR, YDMSG%NUNDF_, YDMSG%XUNDF_, MD, VALUES_SP, HOOKS ) +#endif !> Free the encoded metadata PP_TRYCALL(ERRFLAG_UNABLE_DEALLOCATE_METADATA) DESTROY_METADATA( MD, HOOKS ) @@ -2973,7 +3479,9 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, PP_TRYCALL(ERRFLAG_UNABLE_CHECK_LIST) METADATA_LIST%IS_EMPTY( IS_EMPTY, HOOKS ) ENDDO -#endif + + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) + ! PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_PAR%WRITE_TO_YAML( 6_JPIB_K, 0, HOOKS ) !> Free the message/parametrization PP_TRYCALL(ERRFLAG_UNABLE_TO_FREE_MSG) IN_MSG%FREE( HOOKS ) @@ -3025,6 +3533,24 @@ PP_THREAD_SAFE FUNCTION GRIB_HEADER2MULTIO_WRITE_WAM_SP( THIS, YDMSG, VALUES_SP, PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to write the message' ) CASE (ERRFLAG_UNABLE_DEALLOCATE_METADATA) PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate the metadata' ) + CASE (ERRFLAG_MARS_TO_JSON) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to convert MARS to JSON' ) + CASE (ERRFLAG_UNABLE_TO_DEALLOCATE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to deallocate json' ) + IF ( ALLOCATED(ERRMSG) ) THEN + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Error message: '//TRIM(ADJUSTL(ERRMSG)) ) + DEALLOCATE( ERRMSG, STAT=DEALLOC_STAT ) + END IF + CASE (ERRFLAG_UNABLE_TO_FREE_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the message' ) + CASE (ERRFLAG_UNABLE_TO_FREE_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the parametrization' ) + CASE (ERRFLAG_UNABLE_TO_INIT_MSG) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the message' ) + CASE (ERRFLAG_UNABLE_TO_INIT_PAR) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to init the parametrization' ) + CASE (ERRFLAG_METADATA_LIST_FREE) + PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unable to free the metadata list' ) CASE DEFAULT PP_DEBUG_PUSH_MSG_TO_FRAME( 'Unhandled error' ) END SELECT diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 23fdc057c..9e6e10192 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -2,3 +2,4 @@ add_subdirectory(across) add_subdirectory(multio) add_subdirectory(ecom) +add_subdirectory(multiom) diff --git a/tests/multiom/CMakeLists.txt b/tests/multiom/CMakeLists.txt new file mode 100644 index 000000000..d7047a301 --- /dev/null +++ b/tests/multiom/CMakeLists.txt @@ -0,0 +1,2 @@ + +add_subdirectory(knowledge) diff --git a/tests/multiom/knowledge/49r2v9/CMakeLists.txt b/tests/multiom/knowledge/49r2v9/CMakeLists.txt new file mode 100644 index 000000000..830e88157 --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/CMakeLists.txt @@ -0,0 +1,4 @@ +add_subdirectory(mappings) +add_subdirectory(encodings) +add_subdirectory(plans) +add_subdirectory(samples) diff --git a/tests/multiom/knowledge/49r2v9/encodings/CMakeLists.txt b/tests/multiom/knowledge/49r2v9/encodings/CMakeLists.txt new file mode 100644 index 000000000..591fa3339 --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/encodings/CMakeLists.txt @@ -0,0 +1,15 @@ +file(GLOB encoding_rules RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "*.yaml") + + +# Loop through each entry and add it as a subdirectory if it's a directory +foreach(rule ${encoding_rules}) + configure_file(${CMAKE_CURRENT_SOURCE_DIR}/${rule} + ${CMAKE_CURRENT_BINARY_DIR}/${rule} + COPYONLY) +endforeach() + + +install( + FILES ${encoding_rules} + DESTINATION ${MULTIOM_CONFIG_DIR}/${KNOWLEDGE_VERSION}/encodings + PERMISSIONS OWNER_WRITE OWNER_READ GROUP_READ WORLD_READ) diff --git a/tests/multiom/knowledge/49r2v9/encodings/encoding-rules.yaml b/tests/multiom/knowledge/49r2v9/encodings/encoding-rules.yaml new file mode 100644 index 000000000..eb57ad3cc --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/encodings/encoding-rules.yaml @@ -0,0 +1,742 @@ +encoding-rules: + + # + # Rule 1.0 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-hPa-simple-ensemble' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'greater-equal' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'simple' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 36 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 11 + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinhpa' + + ensemble-configurator: + type: 'default' + + data-representation-section: + template-number: 0 + + + # + # Rule 1.1 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-hPa-simple-deterministic' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'composed' + operation: 'none' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'greater-equal' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'simple' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 1 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 8 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinhpa' + + data-representation-section: + template-number: 0 + + # + # Rule 2.0 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-hPa-ccsds-ensemble' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'greater-equal' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'ccsds' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 36 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 11 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinhpa' + + ensemble-configurator: + type: 'default' + + data-representation-section: + template-number: 42 + + # + # Rule 2.1 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-hPa-ccsds-deterministic' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'composed' + operation: 'none' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'greater-equal' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'ccsds' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 1 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 8 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinhpa' + + data-representation-section: + template-number: 42 + + + # + # Rule 3.0 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-Pa-simple-ensemble' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'lower-than' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'simple' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 36 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 11 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinpa' + + ensemble-configurator: + type: 'default' + + data-representation-section: + template-number: 0 + + + # + # Rule 3.1 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-Pa-simple-deterministic' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'composed' + operation: 'none' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'lower-than' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'simple' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 1 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 8 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinpa' + + data-representation-section: + template-number: 0 + + + # + # Rule 4.0 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-Pa-ccsds-ensemble' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'lower-than' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'ccsds' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 36 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 11 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinpa' + + ensemble-configurator: + type: 'default' + + data-representation-section: + template-number: 42 + + + # + # Rule 4.1 + - rule: + + name: 'rule-pl-statistical-ftr3h-isobaricIn-Pa-ccsds-deterministic' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + - type: 'composed' + operation: 'none' + filters: + - type: 'is-ensemble' + + - type: 'param' + operation: 'match' + values: [ 228057, 228059 ] + + - type: 'levtype' + operation: 'match' + values: [ 'pl' ] + + - type: 'levelist' + operation: 'lower-than' + treshold: 100 + + - type: 'repres' + operation: 'match' + values: [ 'gaussian-grid' ] + + - type: 'packing' + operation: 'match' + value: 'ccsds' + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 1 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 8 + + time-statistics-configurator: + type: 'fixed-timerange' + type-of-statistical-processing: 'Average' + overall-length-of-timerange: '3h' + + param-configurator: + type: 'paramIdECMF' + + level-configurator: + type: 'isobaricinpa' + + data-representation-section: + template-number: 42 + + + + - rule: + + name: 'test' + + tag: 'fdb-01' + + filter: + type: 'composed' + operation: 'all' + filters: + + - type: 'param' + operation: 'match' + value: 8 + + - type: 'levtype' + operation: 'match' + value: 'sfc' + + - type: 'levelist' + operation: 'match' + value: 0 + + - type: 'packing' + operation: 'match' + value: 'ccsds' + + - type: 'repres' + operation: 'match' + value: 'gg' + + + encoder: + type: 'grib2' + + indicator-section: + template-number: 0 + + identification-section: + template-number: 0 + origin-configurator: + type: 'default' + sub-centre: 0 + + data-type-configurator: + type: 'default' + + reference-time-configurator: + type: 'default' + + tables-configurator: + type: 'default' + local-tables-version: 0 + + local-use-section: + template-number: 36 + + grid-definition-section: + template-number: 40 + + product-definition-section: + template-number: 0 + point-in-time-configurator: + type: 'default' + + param-configurator: + type: 'paramId' + + level-configurator: + type: 'surface' + + data-representation-section: + template-number: 42 + diff --git a/tests/multiom/knowledge/49r2v9/mappings/CMakeLists.txt b/tests/multiom/knowledge/49r2v9/mappings/CMakeLists.txt new file mode 100644 index 000000000..9b69fc35b --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/mappings/CMakeLists.txt @@ -0,0 +1,15 @@ +file(GLOB mapping_rules RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "*.yaml") + + +# Loop through each entry and add it as a subdirectory if it's a directory +foreach(rule ${mapping_rules}) + configure_file(${CMAKE_CURRENT_SOURCE_DIR}/${rule} + ${CMAKE_CURRENT_BINARY_DIR}/${rule} + COPYONLY) +endforeach() + + +install( + FILES ${mapping_rules} + DESTINATION ${MULTIOM_CONFIG_DIR}/${KNOWLEDGE_VERSION}/mappings + PERMISSIONS OWNER_WRITE OWNER_READ GROUP_READ WORLD_READ) diff --git a/tests/multiom/knowledge/49r2v9/mappings/mapping-rules.yaml b/tests/multiom/knowledge/49r2v9/mappings/mapping-rules.yaml new file mode 100644 index 000000000..8f087b82a --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/mappings/mapping-rules.yaml @@ -0,0 +1,188 @@ +mapping-rules: + + + # change of units example + - rule: + + name: 'modify the units of a specific field' + + tag: 'change-unit' + + filter: + type: 'param' + operation: 'match' + value: 220221 + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'parametrization-float' + name: 'scale-factor' + expression: + type: 'constant' + value: 1000.0 + - type: 'message-int' + name: 'param' + expression: + type: 'constant' + value: 654321 + + # change of units example + - rule: + + name: 'modify the expver and scaling factor' + + tag: 'change expver' + + filter: + type: 'param' + operation: 'match' + value: 220221 + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'parametrization-float' + name: 'scale-factor' + expression: + type: 'constant' + value: 999.0 + - type: 'message-string' + name: 'expver' + value: 'ABCD' + + + # change of units example + - rule: + + name: 'modify the expver for the spherical harmonics fields' + + tag: 'change expver for sh fields' + + filter: + type: 'repres' + operation: 'match' + value: 'sh' + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'message-string' + name: 'expver' + value: 'ABCD' + + + # change packing type injecting a new constant through an enumerator (changing the packing type to simple) + - rule: + + name: 'modify the packing type' + + tag: 'change packing type for some fields' + + filter: + type: 'param' + operation: 'match' + value: 162112 + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'message-int' + name: 'packing' + expression: + type: 'enum' + name: 'packing' + value: 'simple' + + # change bits-per-value of some fields + - rule: + + name: 'modify the bits per value' + + tag: 'change packing type for some fields' + + filter: + type: 'param' + operation: 'match' + values: [ 8, 9, 26, 228007 ] + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'parametrization-int' + name: 'bits-per-value' + expression: + type: 'constant' + value: 25 + + + # change of units example + - rule: + + name: 'copy spherical harmonics fields with original expver' + + tag: 'copy sh fields' + + filter: + type: 'repres' + operation: 'match' + value: 'sh' + + assignment: + type: 'copy' + + # change of units example + - rule: + + name: 'modify the units of a specific field (not supposed to match)' + + tag: 'change-unit-not-match' + + filter: + type: 'param' + operation: 'match' + value: 220222 + + assignment: + type: 'composed' + chained: true + assignments: + - type: 'copy' + - type: 'composed' + chained: false + assignments: + - type: 'parametrization-float' + name: 'scale-factor' + expression: + type: 'constant' + value: 1000.0 + - type: 'message-int' + name: 'param' + expression: + type: 'constant' + value: 654321 diff --git a/tests/multiom/knowledge/49r2v9/plans/CMakeLists.txt b/tests/multiom/knowledge/49r2v9/plans/CMakeLists.txt new file mode 100644 index 000000000..628023f3f --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/plans/CMakeLists.txt @@ -0,0 +1,15 @@ +file(GLOB multio_plans RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "*.yaml") + + +# Loop through each entry and add it as a subdirectory if it's a directory +foreach(plan ${multio_plans}) + configure_file(${CMAKE_CURRENT_SOURCE_DIR}/${plan} + ${CMAKE_CURRENT_BINARY_DIR}/${plan} + COPYONLY) +endforeach() + + +install( + FILES ${multio_plans} + DESTINATION ${MULTIOM_CONFIG_DIR}/${KNOWLEDGE_VERSION}/plans + PERMISSIONS OWNER_WRITE OWNER_READ GROUP_READ WORLD_READ) diff --git a/tests/multiom/knowledge/49r2v9/plans/multio-plans.yaml b/tests/multiom/knowledge/49r2v9/plans/multio-plans.yaml new file mode 100644 index 000000000..e6e03854b --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/plans/multio-plans.yaml @@ -0,0 +1,10 @@ +plans: + + - name: 'Just a test' + actions: + - type: print + stream: out + prefix: "Just a test" + + - type: sink + sinks: [] diff --git a/tests/multiom/knowledge/49r2v9/samples/CMakeLists.txt b/tests/multiom/knowledge/49r2v9/samples/CMakeLists.txt new file mode 100644 index 000000000..7c329ce19 --- /dev/null +++ b/tests/multiom/knowledge/49r2v9/samples/CMakeLists.txt @@ -0,0 +1,15 @@ +file(GLOB samples RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} "*.tmpl") + + +# Loop through each entry and add it as a subdirectory if it's a directory +foreach(sample ${samples}) + configure_file(${CMAKE_CURRENT_SOURCE_DIR}/${sample} + ${CMAKE_CURRENT_BINARY_DIR}/${sample} + COPYONLY) +endforeach() + + +install( + FILES ${samples} + DESTINATION ${MULTIOM_CONFIG_DIR}/${KNOWLEDGE_VERSION}/samples + PERMISSIONS OWNER_WRITE OWNER_READ GROUP_READ WORLD_READ) diff --git a/tests/multiom/knowledge/49r2v9/samples/sample.tmpl b/tests/multiom/knowledge/49r2v9/samples/sample.tmpl new file mode 100644 index 0000000000000000000000000000000000000000..5629720e838bbdb692a2710a036ed0d2c6f47a37 GIT binary patch literal 1124 zcmZ<{@^t$DpMi-13|LZtlqe%Z5(5J(10(x&76~4R1cM+G10xVJu`n7K7#K1zFmf;h zWsDy%F*0bd{l^4A$pnyAkPNGP1DMUw3S@{z^qv3-0_6-C7(^H(8B`cF7<3to7;J#h zgTb32fFTN~H-#aGp#lsW7}^;o0O0~S+`<5Z2N)=WFmtxR&0YYutDT_%YI_dQB?&+m z1pr;<0d}Ji(6t&sS4#q2&%n&Y!mtD6QHK8wKwmL}SeYP#5#&j*HyIol7*;sc9sT0) zCi#k^Uq_YWYJUMI_Vat3{Qk5!%?Q2WbTco`S?o`av(I7!=k~P=oHt~4I6n+O;ljJn z#znt`$0e+$!=?DJ z4vui0xX;3M!M6vl8-6;t9^ALX^|I{+*QePBTz{BnxUpVpaN~by;U?wg;HL7s!%hF^ z2RCc0C2nrZXSfBKyl{&>z~h#wb-=A8!osay&B3i@uY+6XtO;&?asqCXEI+tSeJJ5J zlbyqD_WT)cbLX9MoA>jY+x#T~Zu6%UxXs(g<~CPMz-`u~9d6S#``jkoUFO!iYld6< zWdpZHM;*5kHy5{5wJC0)ArIVK89UreV%E4R&vkGU`trn$X(Eg3Q_BF?WBm!PE6Xxm z`wVxuW`56ewNZ+46?V3Bxi1~zvdEOdCH_o`i-3rX^NOSg&Pv>JP7zll94=+|So=$W z!yXj$g8`UKvWqj%Ouc83>Q!RNx$lJKBy$fd{(}Wp&0?Rd?tPnQZEE0c-F<0>^?5A= z8xi&f8=vC)>`u0=7%@CfFY7xM2G{vBQpC z@{OI$tT}cjffjat(LQ!r7hCLFo&?!VZP2n?F0#ySXVE;nGbxko?r$=%`)nFz&z$CK z&#RMUFLt-qULj4(UUM6Zz0tlC_SVI$_Rfbm?Y-xP*$4f-Xdij~v3-K#Py5s>!uDCO zb?o!gO6-eWRqe~#7ui>u3fWf|f3>f*RJ5;a(Xy{k*