diff --git a/.github/pull_request_template.md b/.github/pull_request_template.md index c431f6a..d8e2960 100644 --- a/.github/pull_request_template.md +++ b/.github/pull_request_template.md @@ -55,18 +55,14 @@ Code Reviewer: - [ ] Performance of the code has been considered and, if applicable, suitable performance measurements have been conducted -## Contributor License Agreement (CLA) - -- [ ] **Required** - I confirm that I have read and agree to the project's - [Contributor License Agreement](todo-enter-link-to-cla) - ## AI Assistance and Attribution - [ ] Some of the content of this change has been produced with the assistance of _Generative AI tool name_ (e.g., Met Office Github Copilot Enterprise, Github Copilot Personal, ChatGPT GPT-4, etc) and I have followed the - [Simulation Systems AI policy](todo-enter-link-to-policy-page) (including - attribution labels) + [Simulation Systems AI policy](https://metoffice.github.io/simulation-systems/FurtherDetails/ai.html)(including attribution labels) + + ## Documentation @@ -78,10 +74,10 @@ Code Reviewer: - [ ] All dependencies have been resolved -- [ ] Related Issues are properly linked and addressed -- [ ] CLA compliance is confirmed -- [ ] Code quality standards are met -- [ ] Tests are adequate and passing +- [ ] Related Issues have been properly linked and addressed +- [ ] CLA compliance has been confirmed +- [ ] Code quality standards have been met +- [ ] Tests are adequate and have passed - [ ] Documentation is complete and accurate - [ ] Security considerations have been addressed - [ ] Performance impact is acceptable diff --git a/.github/workflows/check-cr-approved.yaml b/.github/workflows/check-cr-approved.yaml new file mode 100644 index 0000000..9b66712 --- /dev/null +++ b/.github/workflows/check-cr-approved.yaml @@ -0,0 +1,11 @@ +name: Check CR approved + +on: + pull_request_review: + types: [submitted, edited, dismissed] + workflow_dispatch: + +jobs: + check_cr_approved: + if: ${{ github.event.pull_request.number }} + uses: MetOffice/growss/.github/workflows/check-cr-approved.yaml@main diff --git a/.github/workflows/checks.yaml b/.github/workflows/checks.yaml index b98e224..cebc29e 100644 --- a/.github/workflows/checks.yaml +++ b/.github/workflows/checks.yaml @@ -2,6 +2,10 @@ name: Quality on: # yamllint disable-line rule:truthy + push: + branches: + - main + - 'releases/**' pull_request: types: [opened, synchronize, reopened] workflow_dispatch: diff --git a/.github/workflows/cla-check.yaml b/.github/workflows/cla-check.yaml new file mode 100644 index 0000000..3d28d73 --- /dev/null +++ b/.github/workflows/cla-check.yaml @@ -0,0 +1,10 @@ +name: Legal + +on: + pull_request_target: + +jobs: + cla: + uses: MetOffice/growss/.github/workflows/cla-check.yaml@main + with: + runner: 'ubuntu-24.04' diff --git a/.github/workflows/track-review-project.yaml b/.github/workflows/track-review-project.yaml new file mode 100644 index 0000000..639477c --- /dev/null +++ b/.github/workflows/track-review-project.yaml @@ -0,0 +1,17 @@ +name: Track Review Project + +on: + workflow_run: + workflows: [Trigger Review Project] + types: + - completed + +permissions: + actions: read + contents: read + pull-requests: write + +jobs: + track_review_project: + uses: MetOffice/growss/.github/workflows/track-review-project.yaml@main + secrets: inherit diff --git a/.github/workflows/trigger-project-workflow.yaml b/.github/workflows/trigger-project-workflow.yaml new file mode 100644 index 0000000..ccb7a55 --- /dev/null +++ b/.github/workflows/trigger-project-workflow.yaml @@ -0,0 +1,17 @@ +name: Trigger Review Project + +on: + pull_request_target: + types: ["opened", "synchronize", "reopened", "edited", "review_requested", "review_request_removed", "closed"] + pull_request_review: + pull_request_review_comment: + +permissions: + actions: read + contents: read + pull-requests: write + +jobs: + trigger_project_workflow: + uses: MetOffice/growss/.github/workflows/trigger-project-workflow.yaml@main + secrets: inherit diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md deleted file mode 100644 index 4823ba9..0000000 --- a/CONTRIBUTING.md +++ /dev/null @@ -1,13 +0,0 @@ -# Contributing Guidelines - -Please follow the -[simulation-systems working practices](https://metoffice.github.io/simulation-systems/index.html) - -By contributing you agree to the -[simulation-systems Contributor Licence Agreement](https://metoffice.github.io/simulation-systems/FurtherDetails/contributing.html) - -Please be aware of and follow the -[simulation-systems Code of Conduct](https://metoffice.github.io/simulation-systems/FurtherDetails/code_of_conduct.html) - -Please be aware of and follow the -[simulation-systems AI Policy](https://metoffice.github.io/simulation-systems/FurtherDetails/ai.html) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md new file mode 100644 index 0000000..b47eb66 --- /dev/null +++ b/CONTRIBUTORS.md @@ -0,0 +1,7 @@ +# Contributors + +| GitHub user | Real Name | Affiliation | Date | +| ----------- | --------- | ----------- | ---- | +| james-bruten-mo | James Bruten | Met Office | 2025-12-09 | +| t00sa | Sam Clarke-Green | Met Office | 2026-02-10 | +| jennyhickson | Jenny Hickson | Met Office | 2026-03-02 | diff --git a/LICENCE b/LICENCE index f3865e0..5f36cd7 100644 --- a/LICENCE +++ b/LICENCE @@ -2,8 +2,8 @@ BSD 3-Clause Licence Crown Copyright (c) Met Office -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. @@ -12,17 +12,17 @@ are permitted provided that the following conditions are met: this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. -3. Neither the name of the copyright holder nor the names of its contributors - may be used to endorse or promote products derived from this software without - specific prior written permission. +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md index 527396a..3ad0632 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ # Shumlib -[![CI](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml) +[![CI](https://github.com/MetOffice/shumlib/actions/workflows/ci.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/ci.yaml) +[![Docs](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/docs.yaml) +[![Quality](https://github.com/MetOffice/shumlib/actions/workflows/checks.yaml/badge.svg)](https://github.com/MetOffice/shumlib/actions/workflows/checks.yaml) Shumlib is the collective name for a set of libraries which are used by the UM; the UK Met Office's Unified Model, that may be of use to external tools or @@ -9,5 +11,37 @@ is to enable developers to quickly and easily access parts of the UM code that are commonly duplicated elsewhere, at the same time benefiting from any improvements or optimisations that might be made in support of the UM itself. -Please follow the -[simulation-systems working practices](https://metoffice.github.io/simulation-systems/index.html) +## Contributing Guidelines + +Welcome! + +The following links are here to help set clear expectations for everyone +contributing to this project. By working together under a shared understanding, +we can continuously improve the project while creating a friendly, inclusive +space for all contributors. + +### Contributors Licence Agreement + +Please see the +[Momentum Contributors Licence Agreement](https://github.com/MetOffice/Momentum/blob/main/CLA.md) + +Agreement of the CLA can be shown by adding yourself to the CONTRIBUTORS file +alongside this one, and is a requirement for contributing to this project. + +### Code of Conduct + +Please be aware of and follow the +[Momentum Code of Coduct](https://github.com/MetOffice/Momentum/blob/main/docs/CODE_OF_CONDUCT.md) + +### Working Practices + +This project is managed as part of the Simulation Systems group of repositories. + +Please follow the Simulation Systems +[Working Practices.](https://metoffice.github.io/simulation-systems/index.html) + +Questions are encouraged in the Simulation Systems +[Discussions.](https://github.com/MetOffice/simulation-systems/discussions) + +Please be aware of and follow the Simulation Systems +[AI Policy.](https://metoffice.github.io/simulation-systems/FurtherDetails/ai.html) diff --git a/fortitude.toml b/fortitude.toml index c9645eb..eb7272a 100644 --- a/fortitude.toml +++ b/fortitude.toml @@ -1,16 +1,12 @@ [check] -exclude = ['.venv'] +exclude = [ + '.venv', + 'fruit/fruit.f90', + 'fruit/fruit_mpi.f90', +] ignore = [ - 'C002', # interface-implicit-typing 'C003', # implicit-external-procedures - 'C061', # missing-intent 'C071', # assumed-size 'C072', # assumed-size-character-intent - 'C081', # initialisation-in-declaration - 'C121', # use-all - 'C141', # missing-exit-or-cycle-label 'E001', # syntax-error - 'MOD011', # old-style-array-literal - 'MOD021', # deprecated-relational-operator - 'S061', # unnamed-end-statement ] diff --git a/fruit/fruit.f90 b/fruit/fruit.f90 index d240133..66fef6f 100644 --- a/fruit/fruit.f90 +++ b/fruit/fruit.f90 @@ -230,7 +230,7 @@ function integer32Equal (number1, number2 ) result (resultValue) resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. else resultValue = .false. @@ -243,7 +243,7 @@ function integer64Equal (number1, number2 ) result (resultValue) resultValue = .false. - if ( number1 .eq. number2 ) then + if ( number1 == number2 ) then resultValue = .true. else resultValue = .false. @@ -256,7 +256,7 @@ function stringEqual (str1, str2 ) result (resultValue) resultValue = .false. - if ( str1 .eq. str2 ) then + if ( str1 == str2 ) then resultValue = .true. end if end function stringEqual @@ -971,7 +971,8 @@ end subroutine fruit_hide_dots_ subroutine run_test_case_named_( tc, tc_name ) interface subroutine tc() - end subroutine + implicit none + end subroutine tc end interface character(*), intent(in) :: tc_name @@ -996,7 +997,7 @@ subroutine tc() !$OMP BARRIER - if ( initial_failed_assert_count .eq. failed_assert_count ) then + if ( initial_failed_assert_count == failed_assert_count ) then ! If no additional assertions failed during the run of this test case ! then the test case was successful successful_case_count = successful_case_count+1 @@ -1015,7 +1016,8 @@ end subroutine run_test_case_named_ subroutine run_test_case_( tc ) interface subroutine tc() - end subroutine + implicit none + end subroutine tc end interface call run_test_case_named_( tc, '_unnamed_' ) @@ -1100,12 +1102,12 @@ end subroutine add_fail_unit_ subroutine obsolete_isAllSuccessful_(result) logical, intent(out) :: result call obsolete_ ('subroutine isAllSuccessful is changed to function is_all_successful.') - result = (failed_assert_count .eq. 0 ) + result = (failed_assert_count == 0 ) end subroutine obsolete_isAllSuccessful_ subroutine is_all_successful(result) logical, intent(out) :: result - result= (failed_assert_count .eq. 0 ) + result= (failed_assert_count == 0 ) end subroutine is_all_successful ! Private, helper routine to wrap lines of success/failed marks @@ -1117,7 +1119,7 @@ subroutine output_mark_( chr ) !$omp critical (FRUIT_OMP_ADD_OUTPUT_MARK) linechar_count = linechar_count + 1 - if ( linechar_count .lt. MAX_MARKS_PER_LINE ) then + if ( linechar_count < MAX_MARKS_PER_LINE ) then write(stdout,"(A1)",ADVANCE='NO') chr else write(stdout,"(A1)",ADVANCE='YES') chr diff --git a/shum_byteswap/test/fruit_test_shum_byteswap.f90 b/shum_byteswap/test/fruit_test_shum_byteswap.f90 index 770c96e..439f9cf 100644 --- a/shum_byteswap/test/fruit_test_shum_byteswap.f90 +++ b/shum_byteswap/test/fruit_test_shum_byteswap.f90 @@ -21,10 +21,30 @@ !******************************************************************************* MODULE fruit_test_shum_byteswap_mod -USE fruit +USE fruit, ONLY: assert_equals, assert_true, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL -USE f_shum_ztables_mod +USE f_shum_ztables_mod, ONLY: & + z0000000000000040, z0000000000000840, z0000000000001040, & + z0000000000001440, z0000000000001840, z0000000000001C40, & + z0000000000002040, z0000000000002240, z0000000000002440, & + z000000000000F03F, z0000000001000000, z0000000002000000, & + z0000000003000000, z0000000004000000, z0000000005000000, & + z0000000006000000, z0000000007000000, z0000000008000000, & + z0000000009000000, z000000000A000000, z00000040, & + z0000004000000000, z00000041, z0000084000000000, & + z0000104000000000, z00001041, z0000144000000000, & + z0000184000000000, z00001C4000000000, z0000204000000000, & + z00002041, z0000224000000000, z0000244000000000, & + z00004040, z0000803F, z00008040, & + z0000A040, z0000C040, z0000E040, & + z0000F03F00000000, z01000000, z0100000000000000, & + z02000000, z0200000000000000, z03000000, & + z0300000000000000, z04000000, z0400000000000000, & + z05000000, z0500000000000000, z06000000, & + z0600000000000000, z07000000, z0700000000000000, & + z08000000, z0800000000000000, z09000000, & + z0900000000000000, z0A000000, z0A00000000000000 IMPLICIT NONE PRIVATE diff --git a/shum_fieldsfile/src/f_shum_fieldsfile.f90 b/shum_fieldsfile/src/f_shum_fieldsfile.f90 index 790a46d..a25d3e7 100644 --- a/shum_fieldsfile/src/f_shum_fieldsfile.f90 +++ b/shum_fieldsfile/src/f_shum_fieldsfile.f90 @@ -276,7 +276,7 @@ FUNCTION unique_id_to_ff(id) RESULT(ff) ! returning the last element in the list NULLIFY(ff) -END FUNCTION +END FUNCTION unique_id_to_ff !------------------------------------------------------------------------------! @@ -1989,8 +1989,8 @@ END FUNCTION f_shum_write_fixed_length_header FUNCTION commit_fixed_length_header(ff, message) RESULT(STATUS) IMPLICIT NONE -TYPE(ff_type) :: ff -CHARACTER(LEN=*) :: message +TYPE(ff_type), INTENT(IN OUT) :: ff +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=INT64) :: STATUS INTEGER(KIND=INT64), ALLOCATABLE :: swap_header(:) @@ -2044,7 +2044,7 @@ END FUNCTION commit_fixed_length_header FUNCTION get_next_free_position(ff) RESULT(POSITION) IMPLICIT NONE -TYPE(ff_type) :: ff +TYPE(ff_type), INTENT(IN) :: ff INTEGER(KIND=INT64) :: POSITION POSITION = f_shum_fixed_length_header_len + 1 @@ -2133,8 +2133,8 @@ END FUNCTION get_next_free_position FUNCTION get_next_populated_position(ff, start) RESULT(POSITION) IMPLICIT NONE -TYPE(ff_type) :: ff -INTEGER(KIND=INT64) :: start +TYPE(ff_type), INTENT(IN) :: ff +INTEGER(KIND=INT64), INTENT(IN) :: start INTEGER(KIND=INT64) :: POSITION POSITION = HUGE(0_int64) @@ -3059,8 +3059,8 @@ END FUNCTION f_shum_write_lookup FUNCTION commit_lookup(ff, message) RESULT(STATUS) IMPLICIT NONE -TYPE(ff_type) :: ff -CHARACTER(LEN=*) :: message +TYPE(ff_type), INTENT(IN OUT) :: ff +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=INT64) :: STATUS INTEGER(KIND=INT64) :: start diff --git a/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 b/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 index 7fcb6d1..eac5cd6 100644 --- a/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 +++ b/shum_fieldsfile/test/fruit_test_shum_fieldsfile.f90 @@ -21,7 +21,8 @@ !******************************************************************************* MODULE fruit_test_shum_fieldsfile_mod -USE fruit +USE fruit, ONLY: assert_equals, assert_false, assert_true, get_failed_count, & + run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -38,7 +39,7 @@ SUBROUTINE c_exit(status) BIND(c,NAME="exit") IMPORT :: C_INT IMPLICIT NONE INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: status -END SUBROUTINE +END SUBROUTINE c_exit END INTERFACE !------------------------------------------------------------------------------! @@ -89,11 +90,14 @@ SUBROUTINE fruit_test_shum_fieldsfile STATUS=get_env_status) ! If the variable exists call again to read it in -IF (get_env_status == 0) THEN +IF (get_env_status == 0 .AND. shum_tmpdir_len > 0) THEN ALLOCATE(CHARACTER(shum_tmpdir_len) :: shum_tmpdir) CALL GET_ENVIRONMENT_VARIABLE("SHUM_TMPDIR", & VALUE=shum_tmpdir, & STATUS=get_env_status) +ELSE + ! Force an error if variable has zero length + get_env_status = 1 END IF ! Now check the status (not an ELSE IF, because that way we can catch the ! failed status of either the first or second call @@ -153,7 +157,7 @@ SUBROUTINE test_end_to_end_direct_write_file IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message INTEGER(KIND=int64) :: ff_id CHARACTER(LEN=*), PARAMETER :: tempfile="fruit_test_fieldsfile_direct.ff" @@ -223,6 +227,8 @@ SUBROUTINE test_end_to_end_direct_write_file LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) @@ -875,7 +881,7 @@ SUBROUTINE test_end_to_end_sequential_write_file IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message INTEGER(KIND=int64) :: ff_id CHARACTER(LEN=*), PARAMETER :: tempfile="fruit_test_fieldsfile_sequential.ff" @@ -945,6 +951,8 @@ SUBROUTINE test_end_to_end_sequential_write_file LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) @@ -1551,7 +1559,7 @@ SUBROUTINE test_stashmaster_read IMPLICIT NONE INTEGER(KIND=int64) :: status -CHARACTER(LEN=500) :: message = "" +CHARACTER(LEN=500) :: message CHARACTER(LEN=1) :: newline TYPE(shum_STASHmaster), ALLOCATABLE :: STASHmaster(:) @@ -1566,6 +1574,8 @@ SUBROUTINE test_stashmaster_read INTEGER(KIND=int64) :: packing_codes(10) LOGICAL(KIND=bool) :: check +message = "" + ! Get the number of failed tests prior to this test starting CALL get_failed_count(failures_at_entry) diff --git a/shum_fieldsfile_class/src/f_shum_field.f90 b/shum_fieldsfile_class/src/f_shum_field.f90 index 4ca496f..04658b3 100644 --- a/shum_fieldsfile_class/src/f_shum_field.f90 +++ b/shum_fieldsfile_class/src/f_shum_field.f90 @@ -223,7 +223,7 @@ END FUNCTION get_lookup FUNCTION set_int_lookup_by_index(self, num_index, value_to_set) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(INOUT) :: self - INTEGER(KIND=int64) :: value_to_set, num_index + INTEGER(KIND=int64), INTENT(IN) :: value_to_set, num_index TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup .OR. num_index < 1_int64) THEN @@ -243,7 +243,8 @@ END FUNCTION set_int_lookup_by_index FUNCTION get_int_lookup_by_index(self, num_index, value_to_get) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: value_to_get, num_index + INTEGER(KIND=int64), INTENT(IN) :: num_index + INTEGER(KIND=int64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup .OR. num_index < 1_int64) THEN @@ -263,8 +264,8 @@ END FUNCTION get_int_lookup_by_index FUNCTION set_real_lookup_by_index(self, num_index, value_to_set) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(INOUT) :: self - INTEGER(KIND=int64) :: num_index - REAL(KIND=real64) :: value_to_set + INTEGER(KIND=int64), INTENT(IN) :: num_index + REAL(KIND=real64), INTENT(IN) :: value_to_set TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup + len_real_lookup .OR. & @@ -289,8 +290,8 @@ END FUNCTION set_real_lookup_by_index FUNCTION get_real_lookup_by_index(self, num_index, value_to_get) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: num_index - REAL(KIND=real64) :: value_to_get + INTEGER(KIND=int64), INTENT(IN) :: num_index + REAL(KIND=real64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: status ! Return status object IF (num_index > len_integer_lookup + len_real_lookup .OR. & @@ -317,7 +318,7 @@ FUNCTION get_stashcode(self, stashcode) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbuser4 IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: stashcode + INTEGER(KIND=int64), INTENT(OUT) :: stashcode TYPE(shum_ff_status_type) :: status ! Return status object IF (self%lookup_int(lbuser4) /= um_imdi) THEN @@ -338,7 +339,7 @@ FUNCTION get_timestring(self, timestring) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbyr, lbmon, lbdat, lbhr, lbmin, lbsec IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - CHARACTER(LEN=16) :: timestring + CHARACTER(LEN=16), INTENT(OUT) :: timestring INTEGER(KIND=int64) :: yr, mon, dat, hr, min, sec TYPE(shum_ff_status_type) :: status ! Return status object @@ -380,7 +381,7 @@ FUNCTION get_level_number(self, level_number) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lblev IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: level_number + INTEGER(KIND=int64), INTENT(OUT) :: level_number TYPE(shum_ff_status_type) :: status ! Return status object level_number = self%lookup_int(lblev) @@ -395,7 +396,7 @@ FUNCTION get_level_eta(self, level_eta) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: blev IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: level_eta + REAL(KIND=real64), INTENT(OUT) :: level_eta TYPE(shum_ff_status_type) :: status ! Return status object ! SHUMlib stores parameters containing the index in the 64-word lookup @@ -413,7 +414,7 @@ END FUNCTION get_level_eta FUNCTION get_real_fctime(self, real_fctime) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: real_fctime + REAL(KIND=real64), INTENT(OUT) :: real_fctime TYPE(shum_ff_status_type) :: status ! Return status object real_fctime = self%fctime_real @@ -428,7 +429,7 @@ FUNCTION get_lbproc(self, proc) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbproc IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: proc + INTEGER(KIND=int64), INTENT(OUT) :: proc TYPE(shum_ff_status_type) :: status ! Return status object proc = self%lookup_int(lbproc) @@ -485,7 +486,7 @@ FUNCTION get_longitudes(self, longitudes) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self REAL(KIND=real64), ALLOCATABLE :: temp_longitudes(:) - REAL(KIND=real64), ALLOCATABLE :: longitudes(:) + REAL(KIND=real64), INTENT(OUT), ALLOCATABLE :: longitudes(:) TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%longitudes)) THEN @@ -532,7 +533,7 @@ FUNCTION get_latitudes(self, latitudes) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self REAL(KIND=real64), ALLOCATABLE :: temp_latitudes(:) - REAL(KIND=real64), ALLOCATABLE :: latitudes(:) + REAL(KIND=real64), INTENT(OUT), ALLOCATABLE :: latitudes(:) TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%latitudes)) THEN @@ -553,8 +554,8 @@ END FUNCTION get_latitudes FUNCTION get_coords(self, x, y, coords) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - REAL(KIND=real64) :: coords(2) + INTEGER(KIND=int64), INTENT(IN) :: x, y + REAL(KIND=real64), INTENT(OUT) :: coords(2) TYPE(shum_ff_status_type) :: status ! Return status object IF (x < 1_int64 .OR. x > SIZE(self%longitudes)) THEN @@ -584,7 +585,7 @@ FUNCTION get_pole_location(self, pole_location) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: bplon, bplat IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: pole_location(2) + REAL(KIND=real64), INTENT(OUT) :: pole_location(2) TYPE(shum_ff_status_type) :: status ! Return status object ! SHUMlib stores parameters containing the index in the 64-word lookup @@ -634,7 +635,7 @@ FUNCTION get_rdata(self, rdata) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbrow, lbnpt IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - REAL(KIND=real64) :: rdata(self%lookup_int(lbnpt), & + REAL(KIND=real64), INTENT(OUT) :: rdata(self%lookup_int(lbnpt), & self%lookup_int(lbrow)) TYPE(shum_ff_status_type) :: status ! Return status object @@ -655,8 +656,8 @@ END FUNCTION get_rdata FUNCTION get_rdata_by_location(self, x, y, rdata) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - REAL(KIND=real64) :: rdata + INTEGER(KIND=int64), INTENT(IN) :: x, y + REAL(KIND=real64), INTENT(OUT) :: rdata TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%rdata)) THEN @@ -714,7 +715,7 @@ FUNCTION get_idata(self, idata) RESULT(status) USE f_shum_lookup_indices_mod, ONLY: lbrow, lbnpt IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: idata(self%lookup_int(lbnpt), & + INTEGER(KIND=int64), INTENT(OUT) :: idata(self%lookup_int(lbnpt), & self%lookup_int(lbrow)) TYPE(shum_ff_status_type) :: status ! Return status object @@ -735,8 +736,8 @@ END FUNCTION get_idata FUNCTION get_idata_by_location(self, x, y, idata) RESULT(status) IMPLICIT NONE CLASS(shum_field_type), INTENT(IN) :: self - INTEGER(KIND=int64) :: x, y - INTEGER(KIND=int64) :: idata + INTEGER(KIND=int64), INTENT(IN) :: x, y + INTEGER(KIND=int64), INTENT(OUT) :: idata TYPE(shum_ff_status_type) :: status ! Return status object IF (ALLOCATED(self%idata)) THEN diff --git a/shum_fieldsfile_class/src/f_shum_file.f90 b/shum_fieldsfile_class/src/f_shum_file.f90 index 12f6e05..d010212 100644 --- a/shum_fieldsfile_class/src/f_shum_file.f90 +++ b/shum_fieldsfile_class/src/f_shum_file.f90 @@ -138,8 +138,8 @@ FUNCTION open_file(self, fname, num_lookup, overwrite) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self CHARACTER(LEN=*), INTENT(IN) :: fname -INTEGER(KIND=INT64), OPTIONAL :: num_lookup -LOGICAL(KIND=bool), OPTIONAL :: overwrite +INTEGER(KIND=INT64), INTENT(IN), OPTIONAL :: num_lookup +LOGICAL(KIND=bool), INTENT(IN), OPTIONAL :: overwrite TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=INT64) :: lookup_size LOGICAL :: exists, read_only @@ -231,11 +231,13 @@ FUNCTION read_header(self) RESULT(STATUS) INTEGER(KIND=INT64), PARAMETER :: fieldsfile_type = 3 INTEGER(KIND=INT64), PARAMETER :: ancil_type = 4 -LOGICAL :: is_variable_resolution = .FALSE. +LOGICAL :: is_variable_resolution LOGICAL :: grid_supported TYPE(shum_ff_status_type) :: STATUS ! Return status object +is_variable_resolution = .FALSE. + ! Read in compulsory headers STATUS%icode = f_shum_read_fixed_length_header( & self%file_identifier, & @@ -929,7 +931,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(tmp_field_data_r64(cols, rows)) - tmp_field_data_r64 = RESHAPE(field_data_r64, (/cols, rows/)) + tmp_field_data_r64 = RESHAPE(field_data_r64, [cols, rows]) STATUS = self%fields(field_number)%set_data(tmp_field_data_r64) IF (STATUS%icode /= shumlib_success) THEN WRITE(STATUS%message, '(A,I0)') 'Error setting data for field ', & @@ -948,7 +950,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(tmp_field_data_i64(cols, rows)) - tmp_field_data_i64 = RESHAPE(field_data_i64, (/cols, rows/)) + tmp_field_data_i64 = RESHAPE(field_data_i64, [cols, rows]) STATUS = self%fields(field_number)%set_data(tmp_field_data_i64) IF (STATUS%icode /= shumlib_success) THEN WRITE(STATUS%message, '(A,I0)') 'Error setting data for field ', & @@ -1002,7 +1004,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) ! Promote to 64-bit ALLOCATE(tmp_field_data_r64(cols, rows)) ALLOCATE(tmp_field_data_r32(cols, rows)) - tmp_field_data_r32 = RESHAPE(field_data_r32, (/cols, rows/)) + tmp_field_data_r32 = RESHAPE(field_data_r32, [cols, rows]) DO j_value = 1, rows DO i_value = 1, cols tmp_field_data_r64(i_value,j_value) = tmp_field_data_r32( & @@ -1030,7 +1032,7 @@ FUNCTION read_field(self, field_number) RESULT(STATUS) ! Promote to 64-bit ALLOCATE(tmp_field_data_i64(cols, rows)) ALLOCATE(tmp_field_data_i32(cols, rows)) - tmp_field_data_i32 = RESHAPE(field_data_i32, (/cols, rows/)) + tmp_field_data_i32 = RESHAPE(field_data_i32, [cols, rows]) DO j_value = 1, rows DO i_value = 1, cols tmp_field_data_i64(i_value, j_value) = tmp_field_data_i32( & @@ -1693,7 +1695,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(field_data_r64(rows*cols)) - field_data_r64 = RESHAPE(tmp_field_data_r64, (/cols * rows/)) + field_data_r64 = RESHAPE(tmp_field_data_r64, [cols * rows]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & @@ -1713,7 +1715,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) RETURN END IF ALLOCATE(field_data_i64(rows*cols)) - field_data_i64 = RESHAPE(tmp_field_data_i64, (/rows * cols/)) + field_data_i64 = RESHAPE(tmp_field_data_i64, [rows * cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & @@ -1776,7 +1778,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) END DO END DO - field_data_r32 = RESHAPE(tmp_field_data_r32, (/rows*cols/)) + field_data_r32 = RESHAPE(tmp_field_data_r32, [rows*cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & field_data_r32, & @@ -1803,7 +1805,7 @@ FUNCTION write_field(self, field_number) RESULT(STATUS) i_value,j_value), INT32) END DO END DO - field_data_i32 = RESHAPE(tmp_field_data_i32, (/rows*cols/)) + field_data_i32 = RESHAPE(tmp_field_data_i32, [rows*cols]) STATUS%icode = f_shum_write_field_data(self%file_identifier, & lookup, & field_data_i32, & @@ -1906,7 +1908,7 @@ FUNCTION get_fixed_length_header(self, fixed_length_header) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: fixed_length_header(f_shum_fixed_length_header_len) +INTEGER(KIND=INT64), INTENT(OUT) :: fixed_length_header(f_shum_fixed_length_header_len) TYPE(shum_ff_status_type) :: STATUS ! Return status object fixed_length_header = self%fixed_length_header @@ -1921,7 +1923,7 @@ FUNCTION set_fixed_length_header_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index, value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index, value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (num_index < 1_int64 .OR. num_index > f_shum_fixed_length_header_len) & @@ -1942,7 +1944,8 @@ FUNCTION get_fixed_length_header_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index, value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +INTEGER(KIND=INT64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (num_index < 1_int64 .OR. num_index > f_shum_fixed_length_header_len) & @@ -1994,7 +1997,7 @@ FUNCTION get_integer_constants(self, integer_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64), ALLOCATABLE :: integer_constants(:) +INTEGER(KIND=INT64), INTENT(IN OUT), ALLOCATABLE :: integer_constants(:) INTEGER(KIND=INT64) :: s_ic TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2024,7 +2027,7 @@ FUNCTION set_integer_constants_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index, value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index, value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%integer_constants)) THEN @@ -2048,7 +2051,8 @@ FUNCTION get_integer_constants_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index, value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +INTEGER(KIND=INT64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%integer_constants)) THEN @@ -2103,7 +2107,7 @@ FUNCTION get_real_constants(self, real_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: real_constants(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: real_constants(:) INTEGER(KIND=INT64) :: s_rc TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2133,8 +2137,8 @@ FUNCTION set_real_constants_by_index(self, num_index, value_to_set) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64) :: value_to_set +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(IN) :: value_to_set TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%real_constants)) THEN @@ -2158,8 +2162,8 @@ FUNCTION get_real_constants_by_index(self, num_index, value_to_get) & RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64) :: value_to_get +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(OUT) :: value_to_get TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (.NOT. ALLOCATED(self%real_constants)) THEN @@ -2219,7 +2223,7 @@ FUNCTION get_level_dependent_constants(self, level_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: level_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: level_dependent_constants(:,:) INTEGER(KIND=INT64) :: s_ldc1,s_ldc2 TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2287,7 +2291,7 @@ FUNCTION get_row_dependent_constants(self, row_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: row_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: row_dependent_constants(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_rdc1,s_rdc2 @@ -2359,7 +2363,7 @@ FUNCTION get_column_dependent_constants(self, column_dependent_constants) & ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: column_dependent_constants(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: column_dependent_constants(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_cdc1,s_cdc2 @@ -2429,7 +2433,7 @@ FUNCTION get_additional_parameters(self, additional_parameters) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: additional_parameters(:,:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: additional_parameters(:,:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ap1, s_ap2 @@ -2496,7 +2500,7 @@ FUNCTION get_extra_constants(self, extra_constants) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: extra_constants(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: extra_constants(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ec @@ -2560,7 +2564,7 @@ FUNCTION get_temp_histfile(self, temp_histfile) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -REAL(KIND=REAL64), ALLOCATABLE :: temp_histfile(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: temp_histfile(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_thf @@ -2594,7 +2598,7 @@ FUNCTION set_compressed_index(self, num_index, compressed_index) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN OUT) :: self -INTEGER(KIND=INT64) :: num_index +INTEGER(KIND=INT64), INTENT(IN) :: num_index REAL(KIND=REAL64), INTENT(IN) :: compressed_index(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -2654,8 +2658,8 @@ FUNCTION get_compressed_index(self, num_index, compressed_index) RESULT(STATUS) ! Arguments CLASS(shum_file_type), INTENT(IN) :: self -INTEGER(KIND=INT64) :: num_index -REAL(KIND=REAL64), ALLOCATABLE :: compressed_index(:) +INTEGER(KIND=INT64), INTENT(IN) :: num_index +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: compressed_index(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object INTEGER(KIND=int64) :: s_ci @@ -2734,7 +2738,7 @@ FUNCTION get_field(self, field_number, field) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self INTEGER(KIND=INT64), INTENT(IN) :: field_number -TYPE(shum_field_type) :: field +TYPE(shum_field_type), INTENT(OUT) :: field TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (field_number > self%num_fields) THEN @@ -2781,7 +2785,7 @@ FUNCTION find_field_indices_in_file(self, found_field_indices, & INTEGER(KIND=INT64), OPTIONAL, INTENT(IN) :: max_returned_fields ! Returned list -INTEGER(KIND=INT64), ALLOCATABLE :: found_field_indices(:) +INTEGER(KIND=INT64), INTENT(IN OUT), ALLOCATABLE :: found_field_indices(:) ! Internal variables TYPE(shum_field_type) :: current_field @@ -2930,7 +2934,7 @@ FUNCTION find_fields_in_file(self, found_fields, max_returned_fields, & INTEGER(KIND=INT64), OPTIONAL, INTENT(IN) :: max_returned_fields ! Returned list -TYPE(shum_field_type), ALLOCATABLE :: found_fields(:) +TYPE(shum_field_type), INTENT(IN OUT), ALLOCATABLE :: found_fields(:) ! Local message string CHARACTER(LEN=256) :: cmessage @@ -3042,7 +3046,7 @@ FUNCTION find_forecast_time(self, found_fctime, stashcode) RESULT(STATUS) INTEGER(KIND=INT64), INTENT(IN) :: stashcode ! Returned list -REAL(KIND=REAL64), ALLOCATABLE :: found_fctime(:) +REAL(KIND=REAL64), INTENT(IN OUT), ALLOCATABLE :: found_fctime(:) TYPE(shum_ff_status_type) :: STATUS ! Return status object @@ -3075,7 +3079,7 @@ END FUNCTION find_forecast_time FUNCTION set_filename(self, fname) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -CHARACTER(LEN=*) :: fname +CHARACTER(LEN=*), INTENT(IN) :: fname TYPE(shum_ff_status_type) :: STATUS ! Return status object IF (ALLOCATED(self%filename)) DEALLOCATE(self%filename) @@ -3090,7 +3094,7 @@ END FUNCTION set_filename FUNCTION get_filename(self, fname) RESULT(STATUS) IMPLICIT NONE CLASS(shum_file_type), INTENT(IN) :: self -CHARACTER(LEN=*) :: fname +CHARACTER(LEN=*), INTENT(OUT) :: fname TYPE(shum_ff_status_type) :: STATUS ! Return status object ! return empty string if filename is not allocated @@ -3205,7 +3209,7 @@ FUNCTION add_field(self, new_field) RESULT(STATUS) ! in the file. IMPLICIT NONE CLASS(shum_file_type), INTENT(IN OUT) :: self -TYPE(shum_field_type) :: new_field +TYPE(shum_field_type), INTENT(IN) :: new_field ! Internal variables TYPE(shum_field_type), ALLOCATABLE :: tmp_fields(:) diff --git a/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 b/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 index 0756b06..70dd892 100644 --- a/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 +++ b/shum_fieldsfile_class/test/fruit_test_shum_fieldsfile_class.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_fieldsfile_class_mod -USE fruit +USE fruit, ONLY: assert_equals, get_failed_count, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -39,7 +39,7 @@ SUBROUTINE c_exit(status) BIND(c,NAME="exit") IMPORT :: C_INT IMPLICIT NONE INTEGER(KIND=C_INT), VALUE, INTENT(IN) :: status -END SUBROUTINE +END SUBROUTINE c_exit END INTERFACE !------------------------------------------------------------------------------! @@ -89,11 +89,14 @@ SUBROUTINE fruit_test_shum_fieldsfile_class STATUS=get_env_status) ! If the variable exists call again to read it in -IF (get_env_status == 0) THEN +IF (get_env_status == 0 .AND. shum_tmpdir_len > 0) THEN ALLOCATE(CHARACTER(shum_tmpdir_len) :: shum_tmpdir) CALL GET_ENVIRONMENT_VARIABLE("SHUM_TMPDIR", & VALUE=shum_tmpdir, & STATUS=get_env_status) +ELSE + ! Force an error if variable has zero length + get_env_status = 1 END IF ! Now check the status (not an ELSE IF, because that way we can catch the ! failed status of either the first or second call diff --git a/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 b/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 index 533ad70..0e3c9fd 100644 --- a/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 +++ b/shum_horizontal_field_interp/test/fruit_test_shum_horizontal_field_interp.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_horizontal_field_interp_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: OUTPUT_UNIT diff --git a/shum_kinds/test/fruit_test_shum_kinds.f90 b/shum_kinds/test/fruit_test_shum_kinds.f90 index af1bd2b..0790928 100644 --- a/shum_kinds/test/fruit_test_shum_kinds.f90 +++ b/shum_kinds/test/fruit_test_shum_kinds.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_kinds_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL diff --git a/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 b/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 index a1022bb..e7c19c0 100644 --- a/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 +++ b/shum_latlon_eq_grids/src/f_shum_latlon_eq_grids.f90 @@ -101,7 +101,7 @@ FUNCTION f_shum_lltoeq_arg64 & REAL(KIND=real64), INTENT(OUT) :: phi_eq(SIZE(phi)) ! Lat (eq) REAL(KIND=real64), INTENT(OUT) :: lambda_eq(SIZE(phi)) ! Long (eq) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -225,7 +225,7 @@ FUNCTION f_shum_lltoeq_arg64_single & REAL(KIND=real64) :: phi_eq_arr(1) REAL(KIND=real64) :: lambda_eq_arr(1) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status phi_arr(1) = phi @@ -255,7 +255,7 @@ FUNCTION f_shum_lltoeq_arg32 & REAL(KIND=real32), INTENT(OUT) :: phi_eq(SIZE(phi)) ! Lat (eq) REAL(KIND=real32), INTENT(OUT) :: lambda_eq(SIZE(phi)) ! Long (eq) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -315,7 +315,7 @@ FUNCTION f_shum_lltoeq_arg32_single & REAL(KIND=real64) :: phi_pole64 REAL(KIND=real64) :: lambda_pole64 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -354,7 +354,7 @@ FUNCTION f_shum_eqtoll_arg64 & REAL(KIND=real64), INTENT(OUT) :: phi(SIZE(phi_eq)) ! Lat (lat-lon) REAL(KIND=real64), INTENT(OUT) :: lambda(SIZE(phi_eq)) ! Long (lat-lon) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -478,7 +478,7 @@ FUNCTION f_shum_eqtoll_arg64_single & REAL(KIND=real64) :: phi_arr(1) REAL(KIND=real64) :: lambda_arr(1) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status phi_eq_arr(1) = phi_eq @@ -508,7 +508,7 @@ FUNCTION f_shum_eqtoll_arg32 & REAL(KIND=real32), INTENT(OUT) :: phi(SIZE(phi_eq)) ! Lat (lat-lon) REAL(KIND=real32), INTENT(OUT) :: lambda(SIZE(phi_eq)) ! Long (lat-lon) -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -568,7 +568,7 @@ FUNCTION f_shum_eqtoll_arg32_single & REAL(KIND=real64) :: phi_pole64 REAL(KIND=real64) :: lambda_pole64 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -606,7 +606,7 @@ FUNCTION f_shum_w_coeff_arg64 & REAL(KIND=real64), INTENT(OUT) :: coeff1(SIZE(lambda)) ! Rotation coeff 1 REAL(KIND=real64), INTENT(OUT) :: coeff2(SIZE(lambda)) ! Rotation coeff 2 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status REAL(KIND=real64) :: a_lambda @@ -723,7 +723,7 @@ FUNCTION f_shum_w_coeff_arg32 & REAL(KIND=real32), INTENT(OUT) :: coeff1(SIZE(lambda)) ! Rotation coeff 1 REAL(KIND=real32), INTENT(OUT) :: coeff2(SIZE(lambda)) ! Rotation coeff 2 -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status @@ -777,7 +777,7 @@ FUNCTION f_shum_w_eqtoll_arg64 & REAL(KIND=real64), INTENT(OUT) :: v(SIZE(coeff1)) ! Wind U compt (lat-lon) REAL(KIND=real64), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status LOGICAL :: l_mdi ! Was an mdi value provided? @@ -830,7 +830,7 @@ FUNCTION f_shum_w_eqtoll_arg32 & REAL(KIND=real32), INTENT(OUT) :: v(SIZE(coeff1)) ! Wind U compt (lat-lon) REAL(KIND=real32), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status REAL(KIND=real64) :: coeff1_64(SIZE(coeff1)) @@ -892,7 +892,7 @@ FUNCTION f_shum_w_lltoeq_arg64 & REAL(KIND=real64), INTENT(OUT) :: v_eq(SIZE(coeff1)) ! Wind U compt (eq) REAL(KIND=real64), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status LOGICAL :: l_mdi ! Was an mdi value provided? @@ -945,7 +945,7 @@ FUNCTION f_shum_w_lltoeq_arg32 & REAL(KIND=real32), INTENT(OUT) :: v_eq(SIZE(coeff1)) ! Wind U compt (eq) REAL(KIND=real32), INTENT(IN), OPTIONAL :: mdi ! Missing data value -CHARACTER(LEN=*) :: message +CHARACTER(LEN=*), INTENT(OUT) :: message INTEGER(KIND=int64) :: status64 INTEGER(KIND=int32) :: status diff --git a/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 b/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 index 97b214f..b9f88b2 100644 --- a/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 +++ b/shum_latlon_eq_grids/test/fruit_test_shum_latlon_eq_grids.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_latlon_eq_grids_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE IMPLICIT NONE diff --git a/shum_number_tools/src/f_shum_is_denormal.F90 b/shum_number_tools/src/f_shum_is_denormal.F90 index 66a5282..9123c78 100644 --- a/shum_number_tools/src/f_shum_is_denormal.F90 +++ b/shum_number_tools/src/f_shum_is_denormal.F90 @@ -209,15 +209,15 @@ LOGICAL FUNCTION f_shum_has_denormal32(x) ! Loop over elements of x and determine if any are infinite ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_INF: DO ix=1,SIZE(x) f_shum_has_denormal32 = f_shum_is_denormal32(x(ix)) - IF (f_shum_has_denormal32) EXIT -END DO + IF (f_shum_has_denormal32) EXIT HAS_INF +END DO HAS_INF END FUNCTION f_shum_has_denormal32 ! To use for multi-dimensional arrays you can call f_shum_has_denormal with the -! array reshaped, e.g. f_shum_has_denormal(RESHAPE(x, (/SIZE(x)/))) +! array reshaped, e.g. f_shum_has_denormal(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -232,7 +232,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_2d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_2d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_2d @@ -249,7 +249,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_2d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_2d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_2d @@ -266,7 +266,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_3d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_3d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_3d @@ -283,7 +283,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_3d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_3d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_3d @@ -300,7 +300,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_4d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_4d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_4d @@ -317,7 +317,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_4d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_4d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_4d @@ -334,7 +334,7 @@ LOGICAL FUNCTION f_shum_has_denormal64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal64_5d = f_shum_has_denormal64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal64_5d = f_shum_has_denormal64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal64_5d @@ -351,7 +351,7 @@ LOGICAL FUNCTION f_shum_has_denormal32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_denormal32_5d = f_shum_has_denormal32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_denormal32_5d = f_shum_has_denormal32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_denormal32_5d diff --git a/shum_number_tools/src/f_shum_is_inf.F90 b/shum_number_tools/src/f_shum_is_inf.F90 index 8f6c787..b9fa03a 100644 --- a/shum_number_tools/src/f_shum_is_inf.F90 +++ b/shum_number_tools/src/f_shum_is_inf.F90 @@ -180,15 +180,15 @@ LOGICAL FUNCTION f_shum_has_inf32(x) ! Loop over elements of x and determine if any are infinite ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_INF: DO ix=1,SIZE(x) f_shum_has_inf32 = f_shum_is_inf32(x(ix)) - IF (f_shum_has_inf32) EXIT -END DO + IF (f_shum_has_inf32) EXIT HAS_INF +END DO HAS_INF END FUNCTION f_shum_has_inf32 ! To use for multi-dimensional arrays you can call f_shum_has_inf with the array -! reshaped, e.g. f_shum_has_inf(RESHAPE(x, (/SIZE(x)/))) +! reshaped, e.g. f_shum_has_inf(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -203,7 +203,7 @@ LOGICAL FUNCTION f_shum_has_inf64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_2d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_2d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_2d @@ -220,7 +220,7 @@ LOGICAL FUNCTION f_shum_has_inf32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_2d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_2d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_2d @@ -237,7 +237,7 @@ LOGICAL FUNCTION f_shum_has_inf64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_3d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_3d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_3d @@ -254,7 +254,7 @@ LOGICAL FUNCTION f_shum_has_inf32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_3d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_3d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_3d @@ -271,7 +271,7 @@ LOGICAL FUNCTION f_shum_has_inf64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_4d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_4d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_4d @@ -288,7 +288,7 @@ LOGICAL FUNCTION f_shum_has_inf32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_4d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_4d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_4d @@ -305,7 +305,7 @@ LOGICAL FUNCTION f_shum_has_inf64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf64_5d = f_shum_has_inf64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf64_5d = f_shum_has_inf64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf64_5d @@ -322,7 +322,7 @@ LOGICAL FUNCTION f_shum_has_inf32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_inf32_5d = f_shum_has_inf32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_inf32_5d = f_shum_has_inf32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_inf32_5d diff --git a/shum_number_tools/src/f_shum_is_nan.F90 b/shum_number_tools/src/f_shum_is_nan.F90 index 21d98f7..2fcf7d4 100644 --- a/shum_number_tools/src/f_shum_is_nan.F90 +++ b/shum_number_tools/src/f_shum_is_nan.F90 @@ -220,15 +220,15 @@ LOGICAL FUNCTION f_shum_has_nan32(x) ! Loop over elements of x and determine if any are NaNs ! Exit immediately if any are found -DO ix=1,SIZE(x) +HAS_NAN: DO ix=1,SIZE(x) f_shum_has_nan32 = f_shum_is_nan32(x(ix)) - IF (f_shum_has_nan32) EXIT -END DO + IF (f_shum_has_nan32) EXIT HAS_NAN +END DO HAS_NAN END FUNCTION f_shum_has_nan32 ! To use for multi-dimensional arrays you can call f_shum_has_nan with the array -! reshaped, e.g. f_shum_has_nan(RESHAPE(x, (/SIZE(x)/))) +! reshaped, e.g. f_shum_has_nan(RESHAPE(x, [SIZE(x)])) !*************************************************************************** ! 2D Array 64-bit version @@ -243,7 +243,7 @@ LOGICAL FUNCTION f_shum_has_nan64_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_2d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_2d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_2d @@ -260,7 +260,7 @@ LOGICAL FUNCTION f_shum_has_nan32_2d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_2d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_2d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_2d @@ -277,7 +277,7 @@ LOGICAL FUNCTION f_shum_has_nan64_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_3d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_3d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_3d @@ -294,7 +294,7 @@ LOGICAL FUNCTION f_shum_has_nan32_3d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_3d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_3d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_3d @@ -311,7 +311,7 @@ LOGICAL FUNCTION f_shum_has_nan64_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_4d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_4d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_4d @@ -328,7 +328,7 @@ LOGICAL FUNCTION f_shum_has_nan32_4d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_4d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_4d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_4d @@ -345,7 +345,7 @@ LOGICAL FUNCTION f_shum_has_nan64_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan64_5d = f_shum_has_nan64(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan64_5d = f_shum_has_nan64(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan64_5d @@ -362,7 +362,7 @@ LOGICAL FUNCTION f_shum_has_nan32_5d(x) ! End of header ! Reshape array and pass through 1d array version -f_shum_has_nan32_5d = f_shum_has_nan32(RESHAPE(x, (/SIZE(x)/))) +f_shum_has_nan32_5d = f_shum_has_nan32(RESHAPE(x, [SIZE(x)])) END FUNCTION f_shum_has_nan32_5d diff --git a/shum_number_tools/test/fruit_test_shum_number_tools.F90 b/shum_number_tools/test/fruit_test_shum_number_tools.F90 index eb0b0bb..82b467c 100644 --- a/shum_number_tools/test/fruit_test_shum_number_tools.F90 +++ b/shum_number_tools/test/fruit_test_shum_number_tools.F90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_number_tools_mod -USE fruit +USE fruit, ONLY: assert_false, assert_not_equals, assert_true, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_INT, C_BOOL @@ -40,7 +40,7 @@ FUNCTION c_test_generate_finf() BIND(c,NAME="c_test_generate_finf") IMPORT :: C_FLOAT IMPLICIT NONE REAL(KIND=C_FLOAT) :: c_test_generate_finf - END FUNCTION + end function c_test_generate_finf END INTERFACE !------------------------------------------------------------------------------! @@ -50,7 +50,7 @@ FUNCTION c_test_generate_dinf() BIND(c,NAME="c_test_generate_dinf") IMPORT :: C_DOUBLE IMPLICIT NONE REAL(KIND=C_DOUBLE) :: c_test_generate_dinf - END FUNCTION + end function c_test_generate_dinf END INTERFACE !------------------------------------------------------------------------------! @@ -60,7 +60,7 @@ FUNCTION c_test_generate_fnan() BIND(c,NAME="c_test_generate_fnan") IMPORT :: C_FLOAT IMPLICIT NONE REAL(KIND=C_FLOAT) :: c_test_generate_fnan - END FUNCTION + end function c_test_generate_fnan END INTERFACE !------------------------------------------------------------------------------! @@ -70,7 +70,7 @@ FUNCTION c_test_generate_dnan() BIND(c,NAME="c_test_generate_dnan") IMPORT :: C_DOUBLE IMPLICIT NONE REAL(KIND=C_DOUBLE) :: c_test_generate_dnan - END FUNCTION + end function c_test_generate_dnan END INTERFACE !------------------------------------------------------------------------------! @@ -80,8 +80,8 @@ SUBROUTINE c_test_generate_fdenormal(denormal_float) & BIND(c,NAME="c_test_generate_fdenormal") IMPORT :: C_FLOAT IMPLICIT NONE - REAL(KIND=C_FLOAT) :: denormal_float - END SUBROUTINE + REAL(KIND=C_FLOAT), INTENT(OUT) :: denormal_float + end subroutine c_test_generate_fdenormal END INTERFACE !------------------------------------------------------------------------------! @@ -91,8 +91,8 @@ SUBROUTINE c_test_generate_ddenormal(denormal_double) & BIND(c,NAME="c_test_generate_ddenormal") IMPORT :: C_DOUBLE IMPLICIT NONE - REAL(KIND=C_DOUBLE) :: denormal_double - END SUBROUTINE + REAL(KIND=C_DOUBLE), INTENT(OUT) :: denormal_double + end subroutine c_test_generate_ddenormal END INTERFACE !------------------------------------------------------------------------------! diff --git a/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 b/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 index 0333c94..5fb7142 100644 --- a/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 +++ b/shum_spiral_search/test/fruit_test_shum_spiral_search.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_spiral_search_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_BOOL @@ -130,7 +130,7 @@ SUBROUTINE sample_6x6_data_32 & LOGICAL(KIND=bool), INTENT(OUT) :: lsm(36) LOGICAL(KIND=bool), INTENT(OUT) :: unres_mask(36) INTEGER(KIND=int32), INTENT(OUT) :: index_unres(5) -REAL(KIND=real32) :: planet_radius +REAL(KIND=real32), INTENT(OUT) :: planet_radius REAL(KIND=real64) :: latitude_64(6) REAL(KIND=real64) :: longitude_64(6) @@ -173,13 +173,13 @@ SUBROUTINE test_spiral6_search_arg64 INTEGER(KIND=int64) :: index_unres(no_point_unres) INTEGER(KIND=int64) :: indices(no_point_unres) -LOGICAL(KIND=bool) :: is_land_field = .TRUE. -LOGICAL(KIND=bool) :: constrained = .FALSE. -LOGICAL(KIND=bool) :: cyclic_domain = .FALSE. +LOGICAL(KIND=bool) :: is_land_field +LOGICAL(KIND=bool) :: constrained +LOGICAL(KIND=bool) :: cyclic_domain -REAL(KIND=real64) :: constrained_max_dist = 200000.0 +REAL(KIND=real64), PARAMETER :: constrained_max_dist = 200000.0 REAL(KIND=real64) :: planet_radius -REAL(KIND=real64) :: dist_step = 3.0 +REAL(KIND=real64), PARAMETER :: dist_step = 3.0 INTEGER(KIND=int64) :: result_land(no_point_unres) INTEGER(KIND=int64) :: result_land_con(no_point_unres) @@ -190,6 +190,10 @@ SUBROUTINE test_spiral6_search_arg64 CHARACTER(LEN=400) :: message CHARACTER(LEN=200) :: case_info +is_land_field = .TRUE. +constrained = .FALSE. +cyclic_domain = .FALSE. + ! Retrieve the set of data points to be tested CALL sample_6x6_data(lats, lons, lsm, unres_mask, index_unres, planet_radius ) @@ -281,13 +285,13 @@ SUBROUTINE test_spiral6_search_arg32 INTEGER(KIND=int32) :: index_unres(no_point_unres) INTEGER(KIND=int32) :: indices(no_point_unres) -LOGICAL(KIND=bool) :: is_land_field = .TRUE. -LOGICAL(KIND=bool) :: constrained = .FALSE. -LOGICAL(KIND=bool) :: cyclic_domain = .FALSE. +LOGICAL(KIND=bool) :: is_land_field +LOGICAL(KIND=bool) :: constrained +LOGICAL(KIND=bool) :: cyclic_domain REAL(KIND=real32) :: planet_radius -REAL(KIND=real32) :: constrained_max_dist = 200000.0 -REAL(KIND=real32) :: dist_step = 3.0 +REAL(KIND=real32), PARAMETER :: constrained_max_dist = 200000.0 +REAL(KIND=real32), PARAMETER :: dist_step = 3.0 INTEGER(KIND=int32) :: result_land(no_point_unres) INTEGER(KIND=int32) :: result_land_con(no_point_unres) @@ -298,6 +302,10 @@ SUBROUTINE test_spiral6_search_arg32 CHARACTER(LEN=400) :: message CHARACTER(LEN=200) :: case_info +is_land_field = .TRUE. +constrained = .FALSE. +cyclic_domain = .FALSE. + ! Retrieve the set of data points to be tested - should find 32bit version CALL sample_6x6_data(lats, lons, lsm, unres_mask, index_unres, & planet_radius ) diff --git a/shum_string_conv/src/f_shum_string_conv.f90 b/shum_string_conv/src/f_shum_string_conv.f90 index f6b56f7..85b1710 100644 --- a/shum_string_conv/src/f_shum_string_conv.f90 +++ b/shum_string_conv/src/f_shum_string_conv.f90 @@ -77,7 +77,7 @@ FUNCTION c_strlen_integer_cstr(cstr) IMPLICIT NONE -CHARACTER(KIND=C_CHAR,LEN=1), TARGET :: cstr(*) +CHARACTER(KIND=C_CHAR,LEN=1), INTENT(IN), TARGET :: cstr(*) INTEGER(KIND=C_INT64_T) :: c_strlen_integer_cstr c_strlen_integer_cstr = INT(c_std_strlen(cstr), KIND=C_INT64_T) @@ -95,7 +95,8 @@ FUNCTION c2f_string_cstr(cstr, cstr_len) IMPLICIT NONE -INTEGER(KIND=C_INT64_T) :: cstr_len, i +INTEGER(KIND=C_INT64_T), INTENT(IN) :: cstr_len +INTEGER(KIND=C_INT64_T) :: i CHARACTER(KIND=C_CHAR,LEN=1), INTENT(IN) :: cstr(cstr_len) CHARACTER(LEN=cstr_len) :: c2f_string_cstr @@ -114,7 +115,8 @@ FUNCTION c2f_string_cptr(cptr, cstr_len) IMPLICIT NONE -INTEGER(KIND=C_INT64_T) :: cstr_len, i +INTEGER(KIND=C_INT64_T), INTENT(IN) :: cstr_len +INTEGER(KIND=C_INT64_T) :: i TYPE(C_PTR), INTENT(IN) :: cptr CHARACTER(KIND=C_CHAR, LEN=1), POINTER :: fptr(:) CHARACTER(LEN=cstr_len) :: c2f_string_cptr diff --git a/shum_string_conv/test/fruit_test_shum_string_conv.f90 b/shum_string_conv/test/fruit_test_shum_string_conv.f90 index fe0ef5a..efe9ebf 100644 --- a/shum_string_conv/test/fruit_test_shum_string_conv.f90 +++ b/shum_string_conv/test/fruit_test_shum_string_conv.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_string_conv_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_CHAR, C_NULL_CHAR, C_PTR, C_LOC diff --git a/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 b/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 index 6b08d02..8b1b966 100644 --- a/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 +++ b/shum_thread_utils/test/fruit_test_shum_thread_utils.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_thread_utils_mod -USE fruit +USE fruit, ONLY: assert_true, run_test_case, set_case_name USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT64_T, C_INT32_T, C_FLOAT, & C_DOUBLE, C_BOOL !$ USE omp_lib @@ -135,7 +135,7 @@ SUBROUTINE c_test_inpar(test_ret,par) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: par + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: par END SUBROUTINE c_test_inpar @@ -149,7 +149,7 @@ SUBROUTINE c_test_threadid(test_ret,tid) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: tid + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: tid END SUBROUTINE c_test_threadid @@ -163,7 +163,7 @@ SUBROUTINE c_test_numthreads(test_ret,numthreads) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: numthreads + INTEGER(KIND=C_INT64_T), INTENT(OUT) :: numthreads END SUBROUTINE c_test_numthreads @@ -177,7 +177,7 @@ SUBROUTINE c_test_threadflush(test_ret,shared1) & IMPLICIT NONE LOGICAL(KIND=C_BOOL), INTENT(OUT) :: test_ret - INTEGER(KIND=C_INT64_T) :: shared1 + INTEGER(KIND=C_INT64_T), INTENT(IN) :: shared1 END SUBROUTINE c_test_threadflush diff --git a/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 b/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 index c0756d1..e50fc75 100644 --- a/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/src/f_shum_wgdos_packing.f90 @@ -147,7 +147,7 @@ FUNCTION f_shum_read_wgdos_header_arg64( & cols = INT(cols_32, KIND=int64) rows = INT(rows_32, KIND=int64) -END FUNCTION +END FUNCTION f_shum_read_wgdos_header_arg64 !------------------------------------------------------------------------------! diff --git a/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 b/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 index 6900b53..b7a5e23 100644 --- a/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 +++ b/shum_wgdos_packing/test/fruit_test_shum_wgdos_packing.f90 @@ -21,7 +21,7 @@ !******************************************************************************* MODULE fruit_test_shum_wgdos_packing_mod -USE fruit +USE fruit, ONLY: assert_equals, run_test_case USE, INTRINSIC :: ISO_C_BINDING, ONLY: & C_INT64_T, C_INT32_T, C_FLOAT, C_DOUBLE, C_LOC, C_F_POINTER @@ -197,9 +197,9 @@ END SUBROUTINE sample_unpacked_data_1d SUBROUTINE sample_packed_data(sample) IMPLICIT NONE -INTEGER(KIND=int32) :: sample(21) -INTEGER(KIND=int32), POINTER :: sample_pointer(:) -INTEGER(KIND=int64), TARGET :: sample64(11) +INTEGER(KIND=int32), INTENT(OUT) :: sample(21) +INTEGER(KIND=int32), POINTER :: sample_pointer(:) +INTEGER(KIND=int64), TARGET :: sample64(11) ! Define the data as a 64-bit array. The reason for this is that although the ! packing algorithm represents the data as 32-bit, the actual array is just a