From cee64a433da7fa278d48ca404c243692cf0feaf5 Mon Sep 17 00:00:00 2001 From: Balwinder Date: Tue, 17 Jan 2017 15:55:34 -0500 Subject: [PATCH] Fixes non-BFB issue with F-compsets when threading is used This PR addresses an issue which makes the model non-deterministic (i.e. non-BFB) when run with more than one thread. PR #1147 introduced a logical variable (cldfsnow_logic) which was declared and assigned at module level. This kind of declaration automatically sets a variable with 'SAVE' attribute which in turn makes the variable a shared variable (to be shared by all the threads). This PR removes this variables and retain the same functionality. Fixes #1203 [BFB] - Bit-For-Bit --- share/csm_share/README | 31 + .../include/dynamic_vector_procdef.inc | 587 ++ .../include/dynamic_vector_typedef.inc | 266 + share/csm_share/include/shr_assert.h | 10 + share/csm_share/shr/CMakeLists.txt | 27 + share/csm_share/shr/mct_mod.F90 | 1295 +++++ share/csm_share/shr/shr_assert_mod.F90.in | 407 ++ share/csm_share/shr/shr_cal_mod.F90 | 934 +++ share/csm_share/shr/shr_const_mod.F90 | 83 + share/csm_share/shr/shr_dmodel_mod.F90 | 1562 +++++ share/csm_share/shr/shr_file_mod.F90 | 1013 ++++ share/csm_share/shr/shr_flux_mod.F90 | 1477 +++++ share/csm_share/shr/shr_infnan_mod.F90.in | 407 ++ share/csm_share/shr/shr_kind_mod.F90 | 24 + share/csm_share/shr/shr_log_mod.F90 | 99 + share/csm_share/shr/shr_map_mod.F90 | 3432 +++++++++++ share/csm_share/shr/shr_mct_mod.F90 | 869 +++ share/csm_share/shr/shr_mem_mod.F90 | 101 + share/csm_share/shr/shr_mpi_mod.F90 | 2222 +++++++ share/csm_share/shr/shr_msg_mod.F90 | 211 + share/csm_share/shr/shr_ncread_mod.F90 | 1636 ++++++ share/csm_share/shr/shr_nl_mod.F90 | 88 + share/csm_share/shr/shr_orb_mod.F90 | 792 +++ share/csm_share/shr/shr_pcdf_mod.F90 | 832 +++ share/csm_share/shr/shr_pio_mod.F90 | 802 +++ share/csm_share/shr/shr_precip_mod.F90 | 47 + share/csm_share/shr/shr_reprosum_mod.F90 | 1426 +++++ share/csm_share/shr/shr_reprosumx86.c | 83 + share/csm_share/shr/shr_scam_mod.F90 | 953 +++ share/csm_share/shr/shr_spfn_mod.F90 | 1046 ++++ share/csm_share/shr/shr_strconvert_mod.F90 | 166 + share/csm_share/shr/shr_strdata_mod.F90 | 1521 +++++ share/csm_share/shr/shr_stream_mod.F90 | 3118 ++++++++++ share/csm_share/shr/shr_string_mod.F90 | 1944 +++++++ share/csm_share/shr/shr_sys_mod.F90 | 455 ++ share/csm_share/shr/shr_tInterp_mod.F90 | 565 ++ share/csm_share/shr/shr_timer_mod.F90 | 397 ++ share/csm_share/shr/shr_vmath_mod.F90 | 233 + share/csm_share/shr/shr_wv_sat_mod.F90 | 1068 ++++ .../csm_share/test/old_unit_testers/Makefile | 163 + .../csm_share/test/old_unit_testers/Mkdepends | 327 ++ .../test/old_unit_testers/Mksrcfiles | 60 + .../test/old_unit_testers/bundle_expected.F90 | 212 + .../csm_share/test/old_unit_testers/config.h | 7 + .../test/old_unit_testers/make.Macros | 369 ++ .../csm_share/test/old_unit_testers/namelist | 10 + .../test/old_unit_testers/nl/atm.stdin | 2 + .../test/old_unit_testers/nl/cpl.stdin | 2 + .../test/old_unit_testers/nl/ice.stdin | 2 + .../test/old_unit_testers/nl/lnd.stdin | 2 + .../test/old_unit_testers/nl/ocn.stdin | 2 + .../old_unit_testers/run_dshr_bundle_test | 96 + .../test/old_unit_testers/run_file_test | 68 + .../test/old_unit_testers/test_mod.F90 | 339 ++ .../test/old_unit_testers/test_shr_file.F90 | 220 + .../test/old_unit_testers/test_shr_log.F90 | 28 + .../test/old_unit_testers/test_shr_mpi.F90 | 291 + .../test/old_unit_testers/test_shr_orb.F90 | 47 + .../test/old_unit_testers/test_shr_scam.F90 | 156 + .../old_unit_testers/test_shr_streams.F90 | 663 +++ .../test/old_unit_testers/test_shr_sys.F90 | 75 + .../old_unit_testers/test_shr_tInterp.F90 | 108 + share/csm_share/test/unit/CMakeLists.txt | 21 + .../test/unit/dynamic_vector/CMakeLists.txt | 88 + .../character16_vector_tests.pf.in | 61 + .../dynamic_vector_base_tests.inc | 1152 ++++ .../dynamic_vector_character16.F90 | 22 + .../dynamic_vector/dynamic_vector_int_ptr.F90 | 24 + .../dynamic_vector/dynamic_vector_integer.F90 | 22 + .../unit/dynamic_vector/dynamic_vector_r8.F90 | 25 + .../dynamic_vector/int_ptr_vector_tests.pf.in | 105 + .../dynamic_vector/integer_vector_tests.pf.in | 28 + .../test/unit/dynamic_vector/ptr_wrapper.F90 | 31 + .../unit/dynamic_vector/r8_vector_tests.pf.in | 30 + share/csm_share/test/unit/mock/CMakeLists.txt | 4 + .../mock/shr_sys_mod.nompi_abortthrows.F90 | 53 + .../test/unit/shr_assert_test/CMakeLists.txt | 13 + .../test/unit/shr_assert_test/test_assert.pf | 50 + .../unit/shr_assert_test/test_assert_array.pf | 185 + .../test/unit/shr_assert_test/test_macro.pf | 52 + .../test/unit/shr_assert_test/test_ndebug.pf | 45 + .../test/unit/shr_infnan_test/CMakeLists.txt | 31 + .../test/unit/shr_infnan_test/test_infnan.F90 | 157 + .../test/unit/shr_log_test/CMakeLists.txt | 12 + .../unit/shr_log_test/test_error_printers.pf | 51 + .../test/unit/shr_precip_test/CMakeLists.txt | 12 + .../unit/shr_precip_test/test_shr_precip.pf | 62 + .../test/unit/shr_spfn_test/CMakeLists.txt | 12 + .../test/unit/shr_spfn_test/test_erf_r4.pf | 132 + .../test/unit/shr_spfn_test/test_erf_r8.pf | 132 + .../shr_spfn_test/test_gamma_factorial.pf | 98 + .../test/unit/shr_spfn_test/test_igamma.pf | 42 + .../unit/shr_strconvert_test/CMakeLists.txt | 12 + .../unit/shr_strconvert_test/test_toString.pf | 165 + .../test/unit/shr_string_test/CMakeLists.txt | 19 + .../unit/shr_string_test/test_shr_string.pf | 89 + .../test/unit/shr_vmath_test/CMakeLists.txt | 13 + .../test/unit/shr_vmath_test/test_vmath.F90 | 110 + .../test/unit/shr_wv_sat_test/CMakeLists.txt | 12 + .../test/unit/shr_wv_sat_test/test_wv_sat.pf | 256 + .../test_wv_sat_each_method.pf | 270 + share/csm_share/unit_test_stubs/README | 2 + .../unit_test_stubs/pio/CMakeLists.txt | 7 + share/csm_share/unit_test_stubs/pio/README | 2 + share/csm_share/unit_test_stubs/pio/do_genf90 | 10 + share/csm_share/unit_test_stubs/pio/pio.F90 | 4069 +++++++++++++ .../csm_share/unit_test_stubs/pio/pio.F90.in | 824 +++ share/esmf_wrf_timemgr/CMakeLists.txt | 19 + share/esmf_wrf_timemgr/ESMF.F90 | 19 + share/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 | 102 + share/esmf_wrf_timemgr/ESMF_AlarmMod.F90 | 1042 ++++ share/esmf_wrf_timemgr/ESMF_BaseMod.F90 | 1089 ++++ share/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 | 461 ++ share/esmf_wrf_timemgr/ESMF_CalendarMod.F90 | 502 ++ share/esmf_wrf_timemgr/ESMF_ClockMod.F90 | 1249 ++++ share/esmf_wrf_timemgr/ESMF_FractionMod.F90 | 85 + share/esmf_wrf_timemgr/ESMF_Macros.inc | 36 + share/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 | 45 + share/esmf_wrf_timemgr/ESMF_Stubs.F90 | 154 + .../esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 | 1688 ++++++ share/esmf_wrf_timemgr/ESMF_TimeMgr.inc | 45 + share/esmf_wrf_timemgr/ESMF_TimeMod.F90 | 1570 +++++ share/esmf_wrf_timemgr/Makefile | 60 + share/esmf_wrf_timemgr/MeatMod.F90 | 66 + share/esmf_wrf_timemgr/README | 19 + share/esmf_wrf_timemgr/unittests/Makefile | 63 + share/esmf_wrf_timemgr/unittests/go.csh | 14 + share/esmf_wrf_timemgr/unittests/test.F90 | 312 + .../esmf_wrf_timemgr/unittests/wrf_stuff.F90 | 17 + share/esmf_wrf_timemgr/wrf_error_fatal.F90 | 9 + share/esmf_wrf_timemgr/wrf_message.F90 | 7 + share/timing/CMakeLists.txt | 24 + share/timing/COPYING | 674 +++ share/timing/ChangeLog | 189 + share/timing/GPTLget_memusage.c | 179 + share/timing/GPTLprint_memusage.c | 120 + share/timing/GPTLutil.c | 82 + share/timing/Makefile | 89 + share/timing/README | 143 + share/timing/f_wrappers.c | 545 ++ share/timing/gptl.c | 5149 +++++++++++++++++ share/timing/gptl.h | 167 + share/timing/gptl.inc | 170 + share/timing/gptl_papi.c | 1326 +++++ share/timing/perf_mod.F90 | 1623 ++++++ share/timing/perf_utils.F90 | 535 ++ share/timing/private.h | 160 + 147 files changed, 63938 insertions(+) create mode 100644 share/csm_share/README create mode 100644 share/csm_share/include/dynamic_vector_procdef.inc create mode 100644 share/csm_share/include/dynamic_vector_typedef.inc create mode 100644 share/csm_share/include/shr_assert.h create mode 100644 share/csm_share/shr/CMakeLists.txt create mode 100644 share/csm_share/shr/mct_mod.F90 create mode 100644 share/csm_share/shr/shr_assert_mod.F90.in create mode 100644 share/csm_share/shr/shr_cal_mod.F90 create mode 100644 share/csm_share/shr/shr_const_mod.F90 create mode 100644 share/csm_share/shr/shr_dmodel_mod.F90 create mode 100644 share/csm_share/shr/shr_file_mod.F90 create mode 100644 share/csm_share/shr/shr_flux_mod.F90 create mode 100644 share/csm_share/shr/shr_infnan_mod.F90.in create mode 100644 share/csm_share/shr/shr_kind_mod.F90 create mode 100644 share/csm_share/shr/shr_log_mod.F90 create mode 100644 share/csm_share/shr/shr_map_mod.F90 create mode 100644 share/csm_share/shr/shr_mct_mod.F90 create mode 100644 share/csm_share/shr/shr_mem_mod.F90 create mode 100644 share/csm_share/shr/shr_mpi_mod.F90 create mode 100644 share/csm_share/shr/shr_msg_mod.F90 create mode 100644 share/csm_share/shr/shr_ncread_mod.F90 create mode 100644 share/csm_share/shr/shr_nl_mod.F90 create mode 100644 share/csm_share/shr/shr_orb_mod.F90 create mode 100644 share/csm_share/shr/shr_pcdf_mod.F90 create mode 100644 share/csm_share/shr/shr_pio_mod.F90 create mode 100644 share/csm_share/shr/shr_precip_mod.F90 create mode 100644 share/csm_share/shr/shr_reprosum_mod.F90 create mode 100644 share/csm_share/shr/shr_reprosumx86.c create mode 100644 share/csm_share/shr/shr_scam_mod.F90 create mode 100644 share/csm_share/shr/shr_spfn_mod.F90 create mode 100644 share/csm_share/shr/shr_strconvert_mod.F90 create mode 100644 share/csm_share/shr/shr_strdata_mod.F90 create mode 100644 share/csm_share/shr/shr_stream_mod.F90 create mode 100644 share/csm_share/shr/shr_string_mod.F90 create mode 100644 share/csm_share/shr/shr_sys_mod.F90 create mode 100644 share/csm_share/shr/shr_tInterp_mod.F90 create mode 100644 share/csm_share/shr/shr_timer_mod.F90 create mode 100644 share/csm_share/shr/shr_vmath_mod.F90 create mode 100644 share/csm_share/shr/shr_wv_sat_mod.F90 create mode 100644 share/csm_share/test/old_unit_testers/Makefile create mode 100755 share/csm_share/test/old_unit_testers/Mkdepends create mode 100755 share/csm_share/test/old_unit_testers/Mksrcfiles create mode 100644 share/csm_share/test/old_unit_testers/bundle_expected.F90 create mode 100644 share/csm_share/test/old_unit_testers/config.h create mode 100644 share/csm_share/test/old_unit_testers/make.Macros create mode 100644 share/csm_share/test/old_unit_testers/namelist create mode 100644 share/csm_share/test/old_unit_testers/nl/atm.stdin create mode 100644 share/csm_share/test/old_unit_testers/nl/cpl.stdin create mode 100644 share/csm_share/test/old_unit_testers/nl/ice.stdin create mode 100644 share/csm_share/test/old_unit_testers/nl/lnd.stdin create mode 100644 share/csm_share/test/old_unit_testers/nl/ocn.stdin create mode 100755 share/csm_share/test/old_unit_testers/run_dshr_bundle_test create mode 100755 share/csm_share/test/old_unit_testers/run_file_test create mode 100644 share/csm_share/test/old_unit_testers/test_mod.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_file.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_log.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_mpi.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_orb.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_scam.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_streams.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_sys.F90 create mode 100644 share/csm_share/test/old_unit_testers/test_shr_tInterp.F90 create mode 100644 share/csm_share/test/unit/CMakeLists.txt create mode 100644 share/csm_share/test/unit/dynamic_vector/CMakeLists.txt create mode 100644 share/csm_share/test/unit/dynamic_vector/character16_vector_tests.pf.in create mode 100644 share/csm_share/test/unit/dynamic_vector/dynamic_vector_base_tests.inc create mode 100644 share/csm_share/test/unit/dynamic_vector/dynamic_vector_character16.F90 create mode 100644 share/csm_share/test/unit/dynamic_vector/dynamic_vector_int_ptr.F90 create mode 100644 share/csm_share/test/unit/dynamic_vector/dynamic_vector_integer.F90 create mode 100644 share/csm_share/test/unit/dynamic_vector/dynamic_vector_r8.F90 create mode 100644 share/csm_share/test/unit/dynamic_vector/int_ptr_vector_tests.pf.in create mode 100644 share/csm_share/test/unit/dynamic_vector/integer_vector_tests.pf.in create mode 100644 share/csm_share/test/unit/dynamic_vector/ptr_wrapper.F90 create mode 100644 share/csm_share/test/unit/dynamic_vector/r8_vector_tests.pf.in create mode 100644 share/csm_share/test/unit/mock/CMakeLists.txt create mode 100644 share/csm_share/test/unit/mock/shr_sys_mod.nompi_abortthrows.F90 create mode 100644 share/csm_share/test/unit/shr_assert_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_assert_test/test_assert.pf create mode 100644 share/csm_share/test/unit/shr_assert_test/test_assert_array.pf create mode 100644 share/csm_share/test/unit/shr_assert_test/test_macro.pf create mode 100644 share/csm_share/test/unit/shr_assert_test/test_ndebug.pf create mode 100644 share/csm_share/test/unit/shr_infnan_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_infnan_test/test_infnan.F90 create mode 100644 share/csm_share/test/unit/shr_log_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_log_test/test_error_printers.pf create mode 100644 share/csm_share/test/unit/shr_precip_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_precip_test/test_shr_precip.pf create mode 100644 share/csm_share/test/unit/shr_spfn_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_spfn_test/test_erf_r4.pf create mode 100644 share/csm_share/test/unit/shr_spfn_test/test_erf_r8.pf create mode 100644 share/csm_share/test/unit/shr_spfn_test/test_gamma_factorial.pf create mode 100644 share/csm_share/test/unit/shr_spfn_test/test_igamma.pf create mode 100644 share/csm_share/test/unit/shr_strconvert_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_strconvert_test/test_toString.pf create mode 100644 share/csm_share/test/unit/shr_string_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_string_test/test_shr_string.pf create mode 100644 share/csm_share/test/unit/shr_vmath_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_vmath_test/test_vmath.F90 create mode 100644 share/csm_share/test/unit/shr_wv_sat_test/CMakeLists.txt create mode 100644 share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat.pf create mode 100644 share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat_each_method.pf create mode 100644 share/csm_share/unit_test_stubs/README create mode 100644 share/csm_share/unit_test_stubs/pio/CMakeLists.txt create mode 100644 share/csm_share/unit_test_stubs/pio/README create mode 100755 share/csm_share/unit_test_stubs/pio/do_genf90 create mode 100644 share/csm_share/unit_test_stubs/pio/pio.F90 create mode 100644 share/csm_share/unit_test_stubs/pio/pio.F90.in create mode 100644 share/esmf_wrf_timemgr/CMakeLists.txt create mode 100644 share/esmf_wrf_timemgr/ESMF.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_AlarmMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_BaseMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_CalendarMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_ClockMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_FractionMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_Macros.inc create mode 100644 share/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_Stubs.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 create mode 100644 share/esmf_wrf_timemgr/ESMF_TimeMgr.inc create mode 100644 share/esmf_wrf_timemgr/ESMF_TimeMod.F90 create mode 100644 share/esmf_wrf_timemgr/Makefile create mode 100644 share/esmf_wrf_timemgr/MeatMod.F90 create mode 100644 share/esmf_wrf_timemgr/README create mode 100644 share/esmf_wrf_timemgr/unittests/Makefile create mode 100755 share/esmf_wrf_timemgr/unittests/go.csh create mode 100644 share/esmf_wrf_timemgr/unittests/test.F90 create mode 100644 share/esmf_wrf_timemgr/unittests/wrf_stuff.F90 create mode 100644 share/esmf_wrf_timemgr/wrf_error_fatal.F90 create mode 100644 share/esmf_wrf_timemgr/wrf_message.F90 create mode 100644 share/timing/CMakeLists.txt create mode 100644 share/timing/COPYING create mode 100644 share/timing/ChangeLog create mode 100644 share/timing/GPTLget_memusage.c create mode 100644 share/timing/GPTLprint_memusage.c create mode 100644 share/timing/GPTLutil.c create mode 100644 share/timing/Makefile create mode 100644 share/timing/README create mode 100644 share/timing/f_wrappers.c create mode 100644 share/timing/gptl.c create mode 100644 share/timing/gptl.h create mode 100644 share/timing/gptl.inc create mode 100644 share/timing/gptl_papi.c create mode 100644 share/timing/perf_mod.F90 create mode 100644 share/timing/perf_utils.F90 create mode 100644 share/timing/private.h diff --git a/share/csm_share/README b/share/csm_share/README new file mode 100644 index 000000000000..8d9a4c569846 --- /dev/null +++ b/share/csm_share/README @@ -0,0 +1,31 @@ +!=============================================================================== +! SVN $Id: README 19883 2009-12-14 23:19:10Z erik $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/README $ +!=============================================================================== + + A description of csm_share + +This module exists to collect code shared between various CCSM components. +Excluding this "shared code" module, CCSM components are built using disjoint +sets of source code. The use of this shared code is similar to the use of +object code libraries where each subdirectory of csm_share is equivalant to +one library. While object library routines are accessed by linking to libraries +during the load phase, these shared code routines are accessed by including the +appropriate source code directory path during the compile phase. + +Motivation for this code sharing includes: + +- facilitating consistent physics between all models. For example, uniform + solar-zenith-angle/orbital calculations and uniform physical constants. +- providing an interface/API between component models and the flux-coupler + component in the CCSM framework. +- avoiding the need for redundant implementations of commonly needed + functionality. For example netCDF file reading, basic mapping (re-gridding) + functionality, and common character string manipulations. + +Current subsets ("libraries") of shared code only include: + +shr - very generic, general-purpose code that is likely to be useful to all + CCSM components. CCSM components may be explicitly required to use some + parts of this code, for example the physical constants module. + diff --git a/share/csm_share/include/dynamic_vector_procdef.inc b/share/csm_share/include/dynamic_vector_procdef.inc new file mode 100644 index 000000000000..4e2c238cc7d8 --- /dev/null +++ b/share/csm_share/include/dynamic_vector_procdef.inc @@ -0,0 +1,587 @@ +! Type-bound procedures for a dynamic vector. + +#ifdef USE_PURE +#define PURE pure +#else +#define PURE +#endif + +! Construct an empty vector. +PURE function new_vector_default() result(new_vec) + ! Create an empty vector + type( VECTOR_NAME ) :: new_vec + + ! Currently, this does nothing. But some compilers may do weird things if + ! you don't "define" new_vec somehow, and clearing the vector is safe. + call new_vec%clear() + +end function new_vector_default + +! Construct a vector from another vector. +PURE function new_vector_copy(vec) result(new_vec) + ! Create a vector from a pre-existing array. + type( VECTOR_NAME ), intent(in) :: vec + type( VECTOR_NAME ) :: new_vec + + new_vec = vec + +end function new_vector_copy + +! Construct a vector from an array. +PURE function new_vector_array(array) result(new_vec) + ! Create a vector from a pre-existing array. + TYPE_NAME, intent(in) :: array(:) + type( VECTOR_NAME ) :: new_vec + + new_vec = array + +end function new_vector_array + +! Query if the vector is empty. +PURE function empty_vec(self) result(is_empty) + class( VECTOR_NAME ), intent(in) :: self + logical :: is_empty + + is_empty = (self%vec_size == 0) + +end function empty_vec + +! Get size of the vector. +PURE function size_vec(self) result(vec_size) + class( VECTOR_NAME ), intent(in) :: self + integer :: vec_size + + vec_size = self%vec_size + +end function size_vec + +! Get maximum size the vector can have. +PURE function max_size_vec(self) result(max_size) + class( VECTOR_NAME ), intent(in) :: self + integer :: max_size + + ! The only theoretical limitation that can be determined without a system + ! call is the maximum size of an integer. + max_size = huge(self%vec_size) + +end function max_size_vec + +! Query current memory capacity of vector. +PURE function capacity_vec(self) result(capacity) + class( VECTOR_NAME ), intent(in) :: self + integer :: capacity + + if (allocated(self%data)) then + capacity = size(self%data) + else + capacity = 0 + end if + +end function capacity_vec + +! Get one item based on an index. +PURE function get_single_vec(self, index) result(item) + class( VECTOR_NAME ), intent(in) :: self + integer, intent(in) :: index + TYPE_NAME, allocatable :: item + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("get", [1, self%vec_size], index)) + ! Purely to satisfy uninitialized data checks. + allocate(item) + return + end if + + allocate(item, source=self%data(index)) + +end function get_single_vec + +! Get items within a certain range. +PURE function get_range_vec(self, begin, end, stride) result(items) + class( VECTOR_NAME ), intent(in) :: self + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + ! Have to use an allocatable, because we have to check if stride is + ! present before we know what the size should be. + TYPE_NAME, allocatable :: items(:) + + ! An oddity: since in Fortran function results must be "defined", we have + ! to allocate "items" to portably avoid a segfault and allow the user to + ! recover from an error. This is true regardless of what the function + ! result is assigned to. + if (end > self%vec_size) then + allocate(items(0)) + THROW(OOBMsg("get", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + allocate(items(0)) + THROW(OOBMsg("get", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + ! For strided access, the number of elements is the size over the + ! stride, but rounded up, rather than down as in typical integer + ! division. The shortcut for this is that (x-1)/y + 1 is the same as + ! x/y rounded up. + allocate(items((end-begin)/stride + 1)) + items = self%data(begin:end:stride) + else + allocate(items(end+1-begin)) + items = self%data(begin:end) + end if + +end function get_range_vec + +! Get an array containing a copy of the vector's elements. +! If array is not allocated, returns a size zero array. +PURE function get_array_vec(self) result(array) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: array(self%vec_size) + + if (allocated(self%data)) then + array = self%data(:self%vec_size) + end if + +end function get_array_vec + +! Get first item in the array +PURE function front_vec(self) result(item) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: item + + item = self%get(1) + +end function front_vec + +! Get last item in the array +PURE function back_vec(self) result(item) + class( VECTOR_NAME ), intent(in) :: self + TYPE_NAME :: item + + item = self%get(self%vec_size) + +end function back_vec + +! Declare the vector to have zero size. +! Does not change vector capacity. +PURE subroutine clear_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + + call self%resize(0) + +end subroutine clear_vec + +! Declare the vector to have different size. +! Does not reduce vector capacity, but will enforce size <= capacity by +! growing array if necessary. +! Resizing to negative value is equivalent to resizing to 0. +PURE subroutine resize_vec(self, new_size, fill_value) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: new_size + TYPE_NAME, intent(in), optional :: fill_value + + integer :: request_capacity + + ! If not big enough, request capacity twice as big + ! as we have now (or 4 or 8 or... times, if necessary). + if (new_size > self%capacity()) then + request_capacity = max(self%capacity(),1) + + do while (request_capacity < new_size) + request_capacity = request_capacity * 2 + end do + + call self%reserve(request_capacity) + end if + + if (present(fill_value)) then + self%data((self%vec_size+1):new_size) = fill_value + end if + + self%vec_size = max(new_size,0) + +end subroutine resize_vec + +! Set one item based on an index. +PURE subroutine set_single_vec(self, item, index) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: item + integer, intent(in) :: index + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("set", [1, self%vec_size], index)) + return + end if + + self%data(index) = item + +end subroutine set_single_vec + +! Set range in array. +PURE subroutine set_range_vec(self, array, begin, end, stride) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + if (end > self%vec_size) then + THROW(OOBMsg("set", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("set", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + self%data(begin:end:stride) = array + else + self%data(begin:end) = array + end if + +end subroutine set_range_vec + +! Set range in array with a fill value. +PURE subroutine set_range_fill_vec(self, fill_value, begin, end, stride) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: fill_value + integer, intent(in) :: begin + integer, intent(in) :: end + integer, intent(in), optional :: stride + + if (end > self%vec_size) then + THROW(OOBMsg("set", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("set", [1, self%vec_size], begin)) + return + end if + + if (present(stride)) then + self%data(begin:end:stride) = fill_value + else + self%data(begin:end) = fill_value + end if + +end subroutine set_range_fill_vec + +! Set array from an array. +PURE subroutine set_array_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + + if (size(array) /= self%vec_size) then + THROW("Input array is not the same size as the vector it sets.") + end if + + if (self%vec_size > 0) then + self%data(:self%vec_size) = array(:self%vec_size) + end if + +end subroutine set_array_vec + +! Set array from a fill value. +! Bounds-checking unnecessary; empty arrays are left empty. +PURE subroutine set_fill_vec(self, fill_value) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: fill_value + + if (allocated(self%data)) then + self%data(:self%vec_size) = fill_value + end if + +end subroutine set_fill_vec + +! Add new object as last element. +PURE subroutine push_back_vec(self, item) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: item + + call self%resize(self%vec_size+1) + + call self%set(item, self%vec_size) + +end subroutine push_back_vec + +! Remove last element. +PURE subroutine pop_back_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + + if (self%empty()) then + THROW("Attempted to pop an element from an empty vector.") + end if + + call self%resize(self%vec_size-1) + +end subroutine pop_back_vec + +! Insert element +! Valid values are 1 to self%vec_size+1. +! Inserting at self%vec_size+1 is equivalent to push_back. +PURE subroutine insert_single_vec(self, index, item) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: item + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+1) + + ! Move everything forward + self%data(index+1:self%vec_size) = & + self%data(index:self%vec_size-1) + + call self%set(item, index) + +end subroutine insert_single_vec + +! Insert array +PURE subroutine insert_array_vec(self, index, items) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: items(:) + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+size(items)) + + ! Move everything forward + self%data(index+size(items):self%vec_size) = & + self%data(index:self%vec_size-size(items)) + + call self%set(items, index, index+size(items)-1) + +end subroutine insert_array_vec + +! Insert repeated value +PURE subroutine insert_repeat_vec(self, index, item, repeats) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + TYPE_NAME, intent(in) :: item + integer, intent(in) :: repeats + + if (index > self%vec_size+1 .or. index < 1) then + THROW(OOBMsg("insert", [1, self%vec_size], index)) + return + end if + + call self%resize(self%vec_size+repeats) + + ! Move everything forward + self%data(index+repeats:self%vec_size) = & + self%data(index:self%vec_size-repeats) + + call self%set(item, index, index+repeats-1) + +end subroutine insert_repeat_vec + +! Erase element +PURE subroutine erase_single_vec(self, index) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: index + + if (index > self%vec_size .or. index < 1) then + THROW(OOBMsg("erase", [1, self%vec_size], index)) + return + end if + + ! Move everything back + self%data(index:(self%vec_size-1)) = self%data((index+1):self%vec_size) + + call self%pop_back() + +end subroutine erase_single_vec + +! Erase "repeats" elements at index. +PURE subroutine erase_range_vec(self, begin, end) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: begin + integer, intent(in) :: end + + if (end > self%vec_size) then + THROW(OOBMsg("erase", [1, self%vec_size], end)) + return + end if + if (begin < 1) then + THROW(OOBMsg("erase", [1, self%vec_size], begin)) + return + end if + + ! Move everything back + self%data(begin:self%vec_size-end+begin-1) = & + self%data(end+1:self%vec_size) + + call self%resize(self%vec_size - end + begin-1) + +end subroutine erase_range_vec + +! Shrink vector to minimum size necessary to hold all elements. +PURE subroutine shrink_to_fit_vec(self) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, allocatable :: tmp_array(:) + + ! Don't do anything unless we have to. + if (self%vec_size < self%capacity()) then + ! If size is zero, just deallocate array. + if (self%vec_size == 0) then + if (allocated(self%data)) deallocate(self%data) + else + ! Allocate temporary at minimum size + allocate(tmp_array(self%vec_size)) + tmp_array = self%data(:self%vec_size) + + deallocate(self%data) + call move_alloc(tmp_array, self%data) + end if + end if + +end subroutine shrink_to_fit_vec + +! Reserve a certain size, if vector is not already that big. +PURE subroutine reserve_vec(self, capacity) + class( VECTOR_NAME ), intent(inout) :: self + integer, intent(in) :: capacity + + TYPE_NAME, allocatable :: tmp_array(:) + + ! Only do anything if we need to get bigger. + if (capacity > self%capacity()) then + + if (self%empty()) then + ! No data to copy + if (allocated(self%data)) deallocate(self%data) + allocate(self%data(capacity)) + else + ! Allocate new size + allocate(tmp_array(capacity)) + ! Copy data + tmp_array(:self%vec_size) = self%data(:self%vec_size) + + ! Replace array with new copy. + deallocate(self%data) + call move_alloc(tmp_array, self%data) + end if + end if + +end subroutine reserve_vec + +! Move allocatable array into self +! Note: Declaring self as intent(out) automatically empties the vector the +! moment we enter this procedure! +PURE subroutine move_in_vec(self, array) + class( VECTOR_NAME ), intent(out) :: self + TYPE_NAME, allocatable, intent(inout) :: array(:) + + if (allocated(array)) then + call move_alloc(array, self%data) + self%vec_size = size(self%data) + end if + +end subroutine move_in_vec + +! Move self into output allocatable array. +! For empty vector, do not allocate output. +PURE subroutine move_out_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, allocatable, intent(out) :: array(:) + + call self%shrink_to_fit() + + if (.not. self%empty()) then + call move_alloc(self%data, array) + end if + + call self%clear() + +end subroutine move_out_vec + +! Efficient swapping (no de/reallocation) +PURE subroutine swap_vec(self, other) + class( VECTOR_NAME ), intent(inout) :: self + class( VECTOR_NAME ), intent(inout) :: other + + integer :: tmp_size + TYPE_NAME, allocatable :: tmp_array(:) + + ! The following order is designed to work even if self and other are the + ! same vector. + if (allocated(other%data)) then + call move_alloc(other%data, tmp_array) + end if + + if (allocated(self%data)) then +#ifndef CPRPGI + call move_alloc(self%data, other%data) +#else + ! The above should work, but a PGI bug forces us to copy and + ! deallocate. + allocate(other%data, source=self%data) + deallocate(self%data) +#endif + end if + + if (allocated(tmp_array)) then +#ifndef CPRPGI + call move_alloc(tmp_array, self%data) +#else + ! The above should work, but a PGI bug forces us to copy and + ! deallocate. + allocate(self%data, source=tmp_array) + deallocate(tmp_array) +#endif + end if + + tmp_size = other%vec_size + other%vec_size = self%vec_size + self%vec_size = tmp_size + +end subroutine swap_vec + +! Assign self from an array +PURE subroutine array_assign_vec(self, array) + class( VECTOR_NAME ), intent(inout) :: self + TYPE_NAME, intent(in) :: array(:) + + call self%resize(size(array)) + + call self%set(array) + +end subroutine array_assign_vec + +! Assign self from another vector. +! Copy-and-swap is used to ensure that at most one copy of the array is +! performed. +! This would allow assignment to self in other languages, but Fortran 2003 +! is vague about whether this should work, since "other" must be +! "intent(in)" for an assignment, and this routine would modify it if it is +! the same as "self". +! Use of the "target" attribute is intended to mitigate the risk of a +! problem, warning the compiler that the two objects may overlap with other +! variables. +PURE subroutine vector_assign_vec(self, other) + class( VECTOR_NAME ), intent(inout), target :: self + class( VECTOR_NAME ), intent(in), target :: other + + class( VECTOR_NAME ), allocatable :: temp + + allocate(temp, source=other) + + call self%swap(temp) + + deallocate(temp) + +end subroutine vector_assign_vec + +#undef PURE diff --git a/share/csm_share/include/dynamic_vector_typedef.inc b/share/csm_share/include/dynamic_vector_typedef.inc new file mode 100644 index 000000000000..d9cd1b3a2b5c --- /dev/null +++ b/share/csm_share/include/dynamic_vector_typedef.inc @@ -0,0 +1,266 @@ +! +! Clone of C++ standard library vectors +! +! This type is a wrapper for an allocatable array, which provides +! efficient utilities for dynamic array operations, such as appending new +! elements, truncation, and reserving/retaining memory independently from +! changes to the array's apparent size. +! +! Dynamic arrays allocate a somewhat larger buffer of contiguous memory +! (the "capacity") than is actually being used at any given time (the +! "size"). This allow elements to be efficiently added to one end, with the +! object automatically reallocating a new buffer as necessary whenever the +! current capacity is exhausted. The capacity increases geometrically, +! wasting O(N) space, but requiring only O(1) time (amortized) to add each +! element. +! +! One downside is that this wrapper class does not support many of +! Fortran's intrinsic array operations. For instance, if you have a +! vector of reals, and you want to take the sine, you have to either +! iterate in a loop (slow), or set the upper bound yourself (without the +! safety of bounds checking). The latter looks like this: +! +! x = sin(vec%data(:vec%size())) +! +! Because of this, it's probably preferable to use a standard array instead +! of a vector of reals for numerical work. +! +! Because this type uses an allocatable instead of a pointer, it should not +! cause a memory leak. However, deallocation can be forced by using "clear" +! followed by "shrink_to_fit", or by explicit deallocation of the data +! component. +! +! How to create a vector type: +! ---------------------------- +! +! Define VECTOR_NAME and TYPE_NAME in a module, then include this file +! to create the type. Include this file before "contains" in the module, +! and the "procdef" file afterward. +! +! There must be a function in scope called OOBMsg (or a function macro of +! this name). This must accept a string representing the operation, a size +! 2 integer array representing the bounds of the array, and an integer +! representing an index into the array. It should return a string +! representing an error message for out-of-bounds access. +! +! Finally, define the function macro THROW to an error handling mechanism. +! THROW accepts one argument, a string representing an error message. +! +! Some tips: +! ---------- +! +! - Do not directly use the "data" component, unless it's unavoidable to +! get decent efficiency. +! +! - The data is assumed to always have lower bound 1. +! +! - If you are finished with adding/removing elements, you can convert +! this type into a standard allocatable array with the "move_out" +! method. (You can do the reverse conversion cheaply with "move_in".) +! +! - Don't include these files twice in the same module, as this will cause +! name clashes. +! +! - Don't use this type if you need pointers into the array to remain +! valid as you add and remove elements. As with the C++ type, the array +! is often reallocated if you are adding elements, and this invalidates +! pointers into it. +! +! Advanced features: +! ------------------ +! +! - Define the macro "USE_PURE" if you need to mark all methods as pure. +! This effectively requires errors to be silent (because THROW cannot do +! anything useful if it has no side effects). +! +! Developer's notes: +! ------------------ +! +! 1) The main difference from the C++ types is that we use Fortran array +! indexing conventions: +! - Indexing starts at 1, not 0. +! - The last element of a range is included in the range. E.g. using +! "vec%erase(2,3)" erases two elements, not just one. +! - When an array size would be negative, it is treated as size 0. +! - When an operation's ending index is smaller than the beginning +! index, it is a no-op (unless a negative stride is provided). +! +! 2) We could have iterator types like in C++, but they don't really give +! you anything more than integer indices. Other types, like linked +! lists, will likely require companion iterator types. +! +! 3) For access with bounds-checking, C++ uses the "at" method to provide +! references to individual elements. To avoid working with pointers, and +! to provide an interface somewhat closer to Fortran array conventions, +! this type uses set/get methods instead. +! +! These methods are likely to produce extra copies, which may negatively +! impact performance compared to direct access of the underlying data. +! This is one reason why the data component is public, not private. +! +! 4) All vectors with vec_size = 0 are valid empty vectors, regardless of +! whether or not "data" is allocated, and regardless of its size. This +! slightly complicates some of the methods. However, it means that the +! user does not have to initialize vectors, or treat empty vectors +! differently depending on how they became empty. +! +! 5) Dynamic arrays have a time/space tradeoff parameter, which is the +! factor by which the array's capacity grows whenever it is +! automatically reallocated to hold more elements. In this code, the +! factor is 2, which is a common, simple, and reasonably fast choice. +! +! If there is too much wasted memory over a wide range of use cases, +! however, it may be reasonable to consider using 1.5 or even lower +! (with appropriate attention given to rounding issues). + +type VECTOR_NAME + + TYPE_NAME, allocatable :: data(:) + + integer, private :: vec_size = 0 + contains + + !------------------------ + ! Query functions + !------------------------ + + ! Test whether there are any elements present + procedure, pass(self) :: empty => empty_vec + ! Return current size + procedure, pass(self) :: vsize => size_vec + ! Estimate maximum possible size + procedure, pass(self) :: max_size => max_size_vec + ! Return maximum number of elements that can be held before the data + ! array will be reallocated to a larger size. + procedure, pass(self) :: capacity => capacity_vec + + !------------------------ + ! Retrieving data + !------------------------ + + ! Get the value of the element at a particular index + procedure, pass(self), private :: get_single_vec + ! Get an array of values of all the elements within a range + procedure, pass(self), private :: get_range_vec + ! Get a copy of all the data + procedure, pass(self), private :: get_array_vec + ! Generic for all of the above. + generic :: get => get_single_vec, get_range_vec, get_array_vec + + ! Get the value of the first element + procedure, pass(self) :: front => front_vec + ! Get the value of the last element + procedure, pass(self) :: back => back_vec + + !------------------------ + ! Modifying data + !------------------------ + + ! Reset the vector to size 0 (without changing capacity) + procedure, pass(self) :: clear => clear_vec + + ! Resize the vector (will not reduce capacity) + ! Resizing to a larger size than the capacity causes reallocation of the + ! data array. + procedure, pass(self) :: resize => resize_vec + + ! None of the "set" routines below will grow the array. Setting elements + ! past the end of the vector will result in an out-of-bounds error; use + ! "insert", "push_back", or explicit resizing to add elements. + + ! Set the element at a particular index + procedure, pass(self), private :: set_single_vec + ! Set the elements in a range from an array + procedure, pass(self), private :: set_range_vec + ! Fill all the elements in a range with a scalar value + procedure, pass(self), private :: set_range_fill_vec + ! Set the data to a copy of some array + procedure, pass(self), private :: set_array_vec + ! Fill the data will a scalar value + procedure, pass(self), private :: set_fill_vec + ! Generic for all of the above. + generic :: set => set_single_vec, set_range_vec, set_range_fill_vec, & + set_array_vec, set_fill_vec + + ! Add an element to the back of the vector + procedure, pass(self) :: push_back => push_back_vec + ! Remove the element at the back of the vector + procedure, pass(self) :: pop_back => pop_back_vec + + ! All of the insert routines add elements; the vector will be expanded + ! and data shuffled to ensure that this is non-destructive. For a vector + ! of size n, new elements can be inserted anywhere from 1 to n+1. + ! Inserting at point n+1 is equivalent to adding the new elements one- + ! by-one with push_back. + + ! Insert one element at a particular point + procedure, pass(self), private :: insert_single_vec + ! Insert all elements from an array at a particular point + procedure, pass(self), private :: insert_array_vec + ! Insert multiple copies of the same value at a particular point. + procedure, pass(self), private :: insert_repeat_vec + ! Generic for all of the above. + generic :: insert => insert_single_vec, insert_array_vec, insert_repeat_vec + + ! Erase the element at a particular point + procedure, pass(self), private :: erase_single_vec + ! Erase all the elements between two points (inclusive) + procedure, pass(self), private :: erase_range_vec + ! Generic for all of the above. + generic :: erase => erase_single_vec, erase_range_vec + + !------------------------ + ! Adjusting capacity + !------------------------ + + ! Shrink the vector's capacity to fit its size, releasing unneeded + ! memory + procedure, pass(self) :: shrink_to_fit => shrink_to_fit_vec + + ! Expand the vector to have at least as much capacity as requested + ! Mostly useful to avoid unnecessary reallocation when you know that the + ! data is unlikely to exceed some upper bound on its size. + procedure, pass(self) :: reserve => reserve_vec + + !------------------------ + ! Move operations + !------------------------ + + ! Convert an allocatable array into a dynamic vector + ! No copies or reallocations are performed, but afterward the array is + ! no longer allocated. + procedure, pass(self) :: move_in => move_in_vec + + ! Convert a dynamic vector to an allocatable array + ! An empty vector is converted to an unallocated array. A reallocation + ! and copy is often performed otherwise. Afterward the vector is empty. + procedure, pass(self) :: move_out => move_out_vec + + ! Swap the contents of this vector with another one + ! No copies or reallocations are performed. + procedure, pass(self) :: swap => swap_vec + + !------------------------ + ! Copy/assignment + !------------------------ + + ! Overwrite contents of this vector with those of an array + procedure, pass(self), private :: array_assign_vec + ! Overwrite contents of this vector with those of another vector + procedure, pass(self), private :: vector_assign_vec + generic :: assignment(=) => array_assign_vec, vector_assign_vec + +end type VECTOR_NAME + +!------------------------ +! Constructors +!------------------------ + +interface VECTOR_NAME + ! Construct empty vector + module procedure new_vector_default + ! Construct vector as a copy of another vector + module procedure new_vector_copy + ! Construct vector with contents from an array + module procedure new_vector_array +end interface diff --git a/share/csm_share/include/shr_assert.h b/share/csm_share/include/shr_assert.h new file mode 100644 index 000000000000..8cbe490d1757 --- /dev/null +++ b/share/csm_share/include/shr_assert.h @@ -0,0 +1,10 @@ +#ifdef NDEBUG +#define SHR_ASSERT(assert, msg) +#define SHR_ASSERT_ALL(assert, msg) +#define SHR_ASSERT_ANY(assert, msg) +#else +#define SHR_ASSERT(assert, msg) call shr_assert(assert, msg) +#define SHR_ASSERT_ALL(assert, msg) call shr_assert_all(assert, msg) +#define SHR_ASSERT_ANY(assert, msg) call shr_assert_any(assert, msg) +#endif +use shr_assert_mod diff --git a/share/csm_share/shr/CMakeLists.txt b/share/csm_share/shr/CMakeLists.txt new file mode 100644 index 000000000000..87b63287a567 --- /dev/null +++ b/share/csm_share/shr/CMakeLists.txt @@ -0,0 +1,27 @@ +set(genf90_files shr_infnan_mod.F90.in shr_assert_mod.F90.in) + +process_genf90_source_list("${genf90_files}" ${CMAKE_CURRENT_BINARY_DIR} + share_genf90_sources) + +sourcelist_to_parent(share_genf90_sources) + +list(APPEND share_sources "${share_genf90_sources}") + +list(APPEND share_sources shr_file_mod.F90 shr_kind_mod.F90 shr_const_mod.F90 + shr_sys_mod.F90 shr_log_mod.F90 shr_orb_mod.F90 shr_spfn_mod.F90 shr_strconvert_mod.F90 + shr_nl_mod.F90 shr_precip_mod.F90 shr_string_mod.F90 shr_timer_mod.F90 shr_vmath_mod.F90 + shr_wv_sat_mod.F90) + +# Build a separate list containing the mct wrapper and its dependencies. That +# way, this list can be easily included in unit test builds that link to mct, +# but excluded from builds that do not include mct. +list(APPEND share_mct_sources mct_mod.F90 shr_mct_mod.F90 shr_mpi_mod.F90 shr_pcdf_mod.F90) + +# Build a separate list containing the pio wrapper and its dependencies. That +# way, this list can be easily included in unit test builds that include PIO or +# a stub of PIO, but excluded from builds that do not include PIO. +list(APPEND share_pio_sources shr_pio_mod.F90) + +sourcelist_to_parent(share_sources) +sourcelist_to_parent(share_mct_sources) +sourcelist_to_parent(share_pio_sources) diff --git a/share/csm_share/shr/mct_mod.F90 b/share/csm_share/shr/mct_mod.F90 new file mode 100644 index 000000000000..4618843c6fd8 --- /dev/null +++ b/share/csm_share/shr/mct_mod.F90 @@ -0,0 +1,1295 @@ +!=============================================================================== +! SVN $Id: mct_mod.F90 65614 2014-11-20 00:39:07Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/mct_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: mct_mod -- provides a standard API naming convention for MCT code +! +! !DESCRIPTION: +! This module should be used instead of accessing mct modules directly. +! This module: +! \begin{itemize} +! \item Uses Fortran {\sf use} renaming of MCT routines and data types so that they +! all have an mct\_ prefix and related data types and routines have related names. +! \item Provides easy and uniform access to +! all MCT routines and data types that must be accessed. +! \item Provides a convienient list of +! all MCT routines and data types that can be accessed. +! \item Blocks access to MCT routines that are not used in cpl6. +! \end{itemize} +! This module also includes some MCT-only functions to augment +! the MCT library. +! +! !REVISION HISTORY: +! 2001-Aug-14 - B. Kauffman - first prototype +! 2006-Apr-13 - M. Vertenstein - modified for sequential mode +! 2007-Mar-01 - R. Jacob - moved to shr +! +! !INTERFACE: ------------------------------------------------------------------ +module mct_mod + +! !USES: + + use shr_kind_mod ! shared kinds + use shr_sys_mod ! share system routines + use shr_mpi_mod ! mpi layer + use shr_const_mod ! constants + use shr_string_mod ! string functions + + use shr_log_mod ,only: s_loglev => shr_log_Level + use shr_log_mod ,only: s_logunit => shr_log_Unit + + use m_MCTWorld ,only: mct_world_init => init + use m_MCTWorld ,only: mct_world_clean => clean + + use m_AttrVect ,only: mct_aVect => AttrVect + use m_AttrVect ,only: mct_aVect_init => init + use m_AttrVect ,only: mct_aVect_clean => clean + use m_AttrVect ,only: mct_aVect_zero => zero + use m_AttrVect ,only: mct_aVect_lsize => lsize + use m_AttrVect ,only: mct_aVect_indexIA => indexIA + use m_AttrVect ,only: mct_aVect_indexRA => indexRA + use m_AttrVect ,only: mct_aVect_importIattr => importIattr + use m_AttrVect ,only: mct_aVect_exportIattr => exportIattr + use m_AttrVect ,only: mct_aVect_importRattr => importRattr + use m_AttrVect ,only: mct_aVect_exportRattr => exportRattr + use m_AttrVect ,only: mct_aVect_getIList => getIList + use m_AttrVect ,only: mct_aVect_getRList => getRList + use m_AttrVect ,only: mct_aVect_getIList2c => getIListToChar + use m_AttrVect ,only: mct_aVect_getRList2c => getRListToChar + use m_AttrVect ,only: mct_aVect_exportIList2c=> exportIListToChar + use m_AttrVect ,only: mct_aVect_exportRList2c=> exportRListToChar + use m_AttrVect ,only: mct_aVect_nIAttr => nIAttr + use m_AttrVect ,only: mct_aVect_nRAttr => nRAttr + use m_AttrVect ,only: mct_aVect_copy => Copy + use m_AttrVect ,only: mct_aVect_permute => Permute + use m_AttrVect ,only: mct_aVect_unpermute => Unpermute + use m_AttrVect ,only: mct_aVect_SharedIndices=> AVSharedIndices + use m_AttrVect ,only: mct_aVect_setSharedIndices=> SharedIndices + use m_AttrVectComms ,only: mct_aVect_scatter => scatter + use m_AttrVectComms ,only: mct_aVect_gather => gather + use m_AttrVectComms ,only: mct_aVect_bcast => bcast + + use m_GeneralGrid ,only: mct_gGrid => GeneralGrid + use m_GeneralGrid ,only: mct_gGrid_init => init + use m_GeneralGrid ,only: mct_gGrid_clean => clean + use m_GeneralGrid ,only: mct_gGrid_dims => dims + use m_GeneralGrid ,only: mct_gGrid_lsize => lsize + use m_GeneralGrid ,only: mct_ggrid_indexIA => indexIA + use m_GeneralGrid ,only: mct_gGrid_indexRA => indexRA + use m_GeneralGrid ,only: mct_gGrid_exportRattr => exportRattr + use m_GeneralGrid ,only: mct_gGrid_importRattr => importRattr + use m_GeneralGrid ,only: mct_gGrid_exportIattr => exportIattr + use m_GeneralGrid ,only: mct_gGrid_importIattr => importIattr + use m_GeneralGrid ,only: mct_gGrid_permute => permute + use m_GeneralGridComms ,only: mct_gGrid_scatter => scatter + use m_GeneralGridComms ,only: mct_gGrid_gather => gather + use m_GeneralGridComms ,only: mct_gGrid_bcast => bcast + + use m_Transfer ,only: mct_send => Send + use m_Transfer ,only: mct_recv => Recv + + use m_GlobalSegMap ,only: mct_gsMap => GlobalSegMap + use m_GlobalSegMap ,only: mct_gsMap_init => init + use m_GlobalSegMap ,only: mct_gsMap_clean => clean + use m_GlobalSegMap ,only: mct_gsMap_lsize => lsize + use m_GlobalSegMap ,only: mct_gsMap_gsize => gsize + use m_GlobalSegMap ,only: mct_gsMap_gstorage => GlobalStorage + use m_GlobalSegMap ,only: mct_gsMap_ngseg => ngseg + use m_GlobalSegMap ,only: mct_gsMap_nlseg => nlseg + use m_GlobalSegMap ,only: mct_gsMap_OP => OrderedPoints + use m_GlobalSegMap ,only: mct_gsMap_maxnlseg => max_nlseg + use m_GlobalSegMap ,only: mct_gsMap_activepes => active_pes + use m_GlobalSegMap ,only: mct_gsMap_copy => copy + use m_GlobalSegMap ,only: mct_gsMap_increasing => increasing + use m_GlobalSegMap ,only: mct_gsMap_orderedPoints=> OrderedPoints + use m_GlobalSegMapComms ,only: mct_gsMap_bcast => bcast + + use m_Rearranger ,only: mct_rearr => Rearranger + use m_Rearranger ,only: mct_rearr_init => init + use m_Rearranger ,only: mct_rearr_clean => clean + use m_Rearranger ,only: mct_rearr_print => print + use m_Rearranger ,only: mct_rearr_rearrange => rearrange + + use m_Router ,only: mct_router => Router + use m_Router ,only: mct_router_init => init + + use m_SparseMatrixToMaps ,only: mct_sMat_2XgsMap => SparseMatrixToXGlobalSegMap + use m_SparseMatrixToMaps ,only: mct_sMat_2YgsMap => SparseMatrixToYGlobalSegMap + use m_SparseMatrix ,only: mct_sMat => SparseMatrix + use m_SparseMatrix ,only: mct_sMat_Init => init + use m_SparseMatrix ,only: mct_sMat_Vecinit => vecinit + use m_SparseMatrix ,only: mct_sMat_Clean => clean + use m_SparseMatrix ,only: mct_sMat_indexIA => indexIA + use m_SparseMatrix ,only: mct_sMat_indexRA => indexRA + use m_SparseMatrix ,only: mct_sMat_lsize => lsize + use m_SparseMatrix ,only: mct_sMat_nrows => nRows + use m_SparseMatrix ,only: mct_sMat_ncols => nCols + use m_SparseMatrix ,only: mct_sMat_SortPermute => SortPermute + use m_SparseMatrix ,only: mct_sMat_GNumEl => GlobalNumElements + use m_SparseMatrix ,only: mct_sMat_ImpGRowI => ImportGlobalRowIndices + use m_SparseMatrix ,only: mct_sMat_ImpGColI => ImportGlobalColumnIndices + use m_SparseMatrix ,only: mct_sMat_ImpLRowI => ImportLocalRowIndices + use m_SparseMatrix ,only: mct_sMat_ImpLColI => ImportLocalColumnIndices + use m_SparseMatrix ,only: mct_sMat_ImpMatrix => ImportMatrixElements + use m_SparseMatrix ,only: mct_sMat_ExpGRowI => ExportGlobalRowIndices + use m_SparseMatrix ,only: mct_sMat_ExpGColI => ExportGlobalColumnIndices + use m_SparseMatrix ,only: mct_sMat_ExpLRowI => ExportLocalRowIndices + use m_SparseMatrix ,only: mct_sMat_ExpLColI => ExportLocalColumnIndices + use m_SparseMatrix ,only: mct_sMat_ExpMatrix => ExportMatrixElements + use m_SparseMatrixComms ,only: mct_sMat_ScatterByRow => ScatterByRow + use m_SparseMatrixComms ,only: mct_sMat_ScatterByCol => ScatterByColumn + use m_SparseMatrixPlus ,only: mct_sMatP => SparseMatrixPlus + use m_SparseMatrixPlus ,only: mct_sMatP_Init => init + use m_SparseMatrixPlus ,only: mct_sMatP_Vecinit => vecinit + use m_SparseMatrixPlus ,only: mct_sMatP_clean => clean + use m_MatAttrVectMul ,only: mct_sMat_avMult => sMatAvMult + use m_GlobalToLocal ,only: mct_sMat_g2lMat => GlobalToLocalMatrix + + use m_List ,only: mct_list => list + use m_List ,only: mct_list_init => init + use m_List ,only: mct_list_get => get + use m_List ,only: mct_list_nitem => nitem + use m_List ,only: mct_list_clean => clean + use m_string ,only: mct_string => string + use m_string ,only: mct_string_clean => clean + use m_string ,only: mct_string_toChar => toChar + use m_die ,only: mct_perr_die => mp_perr_die + use m_die ,only: mct_die => die + use m_inpak90 + + use m_Permuter ,only: mct_permute => Permute + + use m_MergeSorts ,only: mct_indexset => IndexSet + use m_MergeSorts ,only: mct_indexsort => IndexSort + + implicit none + + public :: mct_aVect_info + public :: mct_aVect_fldIndex + public :: mct_aVect_sharedFields + public :: mct_aVect_initSharedFields + public :: mct_aVect_getRAttr + public :: mct_aVect_putRAttr + public :: mct_aVect_accum + public :: mct_aVect_avg + public :: mct_avect_mult + public :: mct_avect_vecmult + public :: mct_rearr_rearrange_fldlist + public :: mct_gsmap_identical + + logical,public :: mct_usealltoall = .false. + logical,public :: mct_usevector = .false. + +!EOP + + !--- local kinds --- + integer,parameter,private :: R8 = SHR_KIND_R8 + integer,parameter,private :: IN = SHR_KIND_IN + integer,parameter,private :: CL = SHR_KIND_CL + integer,parameter,private :: CX = SHR_KIND_CX + integer,parameter,private :: CXX = SHR_KIND_CXX + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +contains +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_info - print out aVect info for debugging +! +! !DESCRIPTION: +! Print out information about the input MCT {\it AttributeVector} +! {\tt aVect} to stdout. {\tt flag} sets the level of information: +! \begin{enumerate} +! \item print out names of attributes in {\tt aVect}. +! \item also print out local max and min of data in {\tt aVect}. +! \item also print out global max and min of data in {\tt aVect}. +! \item Same as 3 but include name of this routine. +! \end{enumerate} +! If {\tt flag} is 3 or higher, then optional argument {\tt comm} +! must be provided. +! If optional argument {\tt fld} is present, only information for +! that field will be printed. +! If optional argument {\tt istr} is present, it will be output +! before any of the information. +! +! +! !REVISION HISTORY: +! 2003 Jul 01 - B. Kauffman, T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_info(flag,aVect,comm,pe,fld,istr) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + integer(IN) ,intent(in) :: flag ! info level flag + type(mct_aVect),intent(in) :: aVect ! Attribute vector + integer(IN) ,intent(in),optional :: comm ! MPI communicator + integer(IN) ,intent(in),optional :: pe ! processor number + character(*) ,intent(in),optional :: fld ! fld + character(*) ,intent(in),optional :: istr ! string for print + +!EOP + + !--- local --- + integer(IN) :: i,j,k,n ! generic indicies + integer(IN) :: ks,ke ! start and stop k indices + integer(IN) :: nflds ! number of flds in AV to diagnose + integer(IN) :: nsize ! grid point size of AV + type(mct_string) :: item ! mct string + character(CL) :: itemc ! item converted to char + integer(IN) :: comm_loc ! local variable for comm + integer(IN) :: pe_loc ! local variable for pe + logical :: commOK ! is comm available + logical :: peOK ! is pe available + real(R8),allocatable :: minl(:) ! local min + real(R8),allocatable :: ming(:) ! global min + real(R8),allocatable :: maxl(:) ! local max + real(R8),allocatable :: maxg(:) ! global max + + !--- formats --- + character(*),parameter :: subName = '(mct_aVect_info) ' + character(*),parameter :: F00 = "('(mct_aVect_info) ',8a)" + character(*),parameter :: F01 = "('(mct_aVect_info) ',a,i9)" + character(*),parameter :: F02 = "('(mct_aVect_info) ',240a)" + character(*),parameter :: F03 = "('(mct_aVect_info) ',a,2es11.3,i4,2x,a)" + +!------------------------------------------------------------------------------- +! NOTE: has hard-coded knowledge/assumptions about mct aVect data type internals +!------------------------------------------------------------------------------- + + commOK = .false. + peOK = .false. + + if (present(pe)) then + peOK = .true. + pe_loc = pe + endif + if (present(comm)) then + commOK = .true. + comm_loc = comm + if (.not.PEOK) then + call shr_mpi_commrank(comm,pe_loc,subName) + peOK = .true. + endif + endif + + nsize = mct_aVect_lsize(aVect) + + if (present(fld)) then + nflds = 1 + ks = mct_aVect_indexRA(aVect,fld,perrWith=subName) + ke = ks + else + nflds = mct_aVect_nRAttr(aVect) + ks = 1 + ke = nflds + endif + + if (flag >= 1) then + if (present(istr)) then + if (s_loglev > 0) write(s_logunit,*) trim(istr) + endif + if (s_loglev > 0) write(s_logunit,F01) "local size =",nsize + if (associated(aVect%iList%bf)) then + if (s_loglev > 0) write(s_logunit,F02) "iList = ",aVect%iList%bf + endif + if (associated(aVect%rList%bf)) then + if (s_loglev > 0) write(s_logunit,F02) "rList = ",aVect%rList%bf + endif + endif + + if (flag >= 2) then + + allocate(minl(nflds)) + allocate(maxl(nflds)) + + do k=ks,ke + minl(k) = minval(aVect%rAttr(k,:)) + maxl(k) = maxval(aVect%rAttr(k,:)) + enddo + + if (flag >= 4 .and. commOK) then + allocate(ming(nflds)) + allocate(maxg(nflds)) + ming = 0._R8 + maxg = 0._R8 + call shr_mpi_min(minl,ming,comm,subName) + call shr_mpi_max(maxl,maxg,comm,subName) + endif + + do k=ks,ke + call mct_aVect_getRList(item,k,aVect) + itemc = mct_string_toChar(item) + call mct_string_clean(item) + if (s_loglev > 0) write(s_logunit,F03) 'l min/max ',minl(k),maxl(k),k,trim(itemc) + if (flag >= 3 .and. commOK) then + if ((peOK .and. pe_loc == 0) .or. .not.peOK) then + if (s_loglev > 0) write(s_logunit,F03) 'g min/max ',ming(k),maxg(k),k,trim(itemc) + endif + endif + if (flag >= 4 .and. commOK) then + if ((peOK .and. pe_loc == 0) .or. .not.peOK) then + if (s_loglev > 0) write(s_logunit,*) trim(subName),'g min/max ',ming(k),maxg(k),k,trim(itemc) + endif + endif + enddo + + deallocate(minl) + deallocate(maxl) + if (flag >= 4 .and. commOK) then + deallocate(ming) + deallocate(maxg) + endif + + endif + + call shr_sys_flush(s_logunit) + +end subroutine mct_aVect_info + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_fldIndex - get a real fld index from an AVect +! +! !DESCRIPTION: +! Get the field index for a real field in an attribute vector. +! This is like mct_aVect_indexRA but with a calling interface +! that returns the index without any error messages. +! +! !REMARKS: +! This is like the MCT routine indexRA +! +! !REVISION HISTORY: +! 2010 Oct 27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function mct_aVect_fldIndex(aVect,fld) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect),intent(in) :: aVect ! an Attribute vector + character(*) ,intent(in) :: fld ! field name string + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "(mct_aVect_fldIndex) " + character(*),parameter :: F00 = "('(mct_aVect_fldIndex) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + mct_aVect_fldIndex = mct_aVect_indexRA(aVect,trim(fld),perrWith='quiet') + +end function mct_aVect_fldIndex + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_sharedFields - get a shared real fld index from two AVects +! +! !DESCRIPTION: +! Get the shared field index for a real field in two attribute vectors. +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2013 Jul 17 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_sharedFields(aVect1, aVect2, rlistout, ilistout) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect),intent(in) :: aVect1 ! an Attribute vector + type(mct_aVect),intent(in) :: aVect2 ! an Attribute vector + character(*) ,intent(inout),optional :: rlistout ! field name string + character(*) ,intent(inout),optional :: ilistout ! field name string + +!EOP + + !--- local --- + integer(IN) :: nflds1,nflds2 + character(len=CXX) :: list1,list2 + + !--- formats --- + character(*),parameter :: subName = "(mct_aVect_sharedFields) " + character(*),parameter :: F00 = "('(mct_aVect_sharedFields) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (present(rlistout)) then + nflds1 = mct_aVect_nRAttr(aVect1) + nflds2 = mct_aVect_nRAttr(aVect2) + rlistout = '' + list1 = '' + list2 = '' + if (nflds1 > 0 .and. nflds2 > 0) then + list1 = mct_aVect_exportRList2c(aVect1) + list2 = mct_aVect_exportRlist2c(aVect2) + call shr_string_listIntersect(list1,list2,rlistout) + endif + endif + + if (present(ilistout)) then + nflds1 = mct_aVect_nIAttr(aVect1) + nflds2 = mct_aVect_nIAttr(aVect2) + ilistout = '' + list1 = '' + list2 = '' + if (nflds1 > 0 .and. nflds2 > 0) then + list1 = mct_aVect_exportIList2c(aVect1) + list2 = mct_aVect_exportIlist2c(aVect2) + call shr_string_listIntersect(list1,list2,ilistout) + endif + endif + +end subroutine mct_aVect_sharedFields + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_initSharedFields - init new AVect based on shared fields +! from two input aVects +! +! !DESCRIPTION: +! Init new AVect based on shared fields of two input AVects +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2013 Jul 17 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_initSharedFields(aVect1, aVect2, aVect3, lsize) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect),intent(in) :: aVect1 ! an Attribute vector + type(mct_aVect),intent(in) :: aVect2 ! an Attribute vector + type(mct_aVect),intent(inout) :: aVect3 ! new Attribute vector + integer(IN) ,intent(in) :: lsize ! aVect3 size + +!EOP + + !--- local --- + character(len=CXX) :: rlist,ilist + + !--- formats --- + character(*),parameter :: subName = "(mct_aVect_initSharedFields) " + character(*),parameter :: F00 = "('(mct_aVect_initSharedFields) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call mct_aVect_sharedFields(aVect1,aVect2,rlist,ilist) + call mct_aVect_init(aVect3,ilist,rlist,lsize) + +end subroutine mct_aVect_initSharedFields + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_getRAttr - get real F90 array data out of an aVect +! +! !DESCRIPTION: +! Get the data associated with attribute {\tt str} in +! {\it AttributeVector} {\tt aVect} and return in the +! real F90 array data {\tt data}. +! {\tt rcode} will be 0 if succesful, 1 if size of {\tt data} +! does not match size of {\tt aVect} and 2 if {\tt str} is +! not found. +! +! !REMARKS: +! This is like the MCT routine exportRAttr except the output argument +! is not a pointer. +! +! !REVISION HISTORY: +! 2002 Apr xx - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_getRAttr(aVect,str,data,rcode) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) ,intent(in) :: aVect ! an Attribute vector + character(*) ,intent(in) :: str ! field name string + real(R8) ,intent(out) :: data(:) ! an F90 array + integer(IN) ,intent(out) :: rcode ! return code + +!EOP + + !--- local --- + integer(IN) :: k,n,m + integer(IN) :: aVsize + + !--- formats --- + character(*),parameter :: subName = "(mct_aVect_getRAttr) " + character(*),parameter :: F00 = "('(mct_aVect_getRAttr) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + rcode = 0 + + n = mct_aVect_lsize(aVect) + m = size(data) + if (n /= m) then + if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str) + data = SHR_CONST_SPVAL + rcode = 1 + return + end if + + k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName) + if ( k < 1) then + if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k + data = SHR_CONST_SPVAL + rcode = 2 + return + end if + + data(:) = aVect%rAttr(k,:) + +end subroutine mct_aVect_getRAttr + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_putRAttr - put real F90 array data into an aVect +! +! !DESCRIPTION: +! Put the data in array {\tt data} into the {\it AttributeVector} +! {\tt aVect} under the attribute {\tt str}. +! {\tt rcode} will be 0 if succesful, 1 if size of {\tt data} +! does not match size of {\tt aVect} and 2 if {\tt str} is not +! found. +! +! !REMARKS: +! This is like the MCT routine importRAttr except the output argument +! is not a pointer. + +! !REVISION HISTORY: +! 2002 Apr xx - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_putRAttr(aVect,str,data,rcode) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect),intent(inout) :: aVect ! Attribute vector + character(*) ,intent(in) :: str + real(R8) ,intent(in) :: data(:) + integer(IN) ,intent(out) :: rcode + +!EOP + + !--- local --- + integer(IN) :: k,n,m + integer(IN) :: aVsize + + !--- formats --- + character(*),parameter :: subName = "(mct_aVect_putRAttr) " + character(*),parameter :: F00 = "('(mct_aVect_putRAttr) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + rcode = 0 + + n = mct_aVect_lsize(aVect) + m = size(data) + if (n /= m) then + if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: size aV,data,attr = ",n,m,trim(str) + rcode = 1 + return + end if + + k = mct_aVect_indexRA(aVect,trim(str) ,perrWith=subName) + if ( k < 1) then + if (s_loglev > 0) write(s_logunit,*) subName,"ERROR: attribute not found, var = ",trim(str),", k=",k + rcode = 2 + return + end if + + aVect%rAttr(k,:) = data(:) + +end subroutine mct_aVect_putRAttr + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_accum - accumulate attributes from one aVect to another +! +! !DESCRIPTION: +! This routine accumulates from input argment {\tt aVin} into the output +! {\it AttrVect} argument {\tt aVout} the real and integer attributes specified in +! input {\tt CHARACTER} argument {\tt iList} and {\tt rList}. The attributes can +! be listed in any order. If neither {\tt iList} nor {\tt rList} are provided, +! all attributes shared between {\tt aVin} and {\tt aVout} will be copied. +! +! If any attributes in {\tt aVout} have different names but represent the +! the same quantity and should still be copied, you must provide a translation +! argument {\tt TrList} and/or {\tt TiList}. The translation arguments should +! be identical to the {\tt rList} or {\tt iList} but with the correct {\tt aVout} +! name subsititued at the appropriate place. +! +! This routine leverages the mct copy routines directly +! +! {\bf N.B.:} This routine will fail if the {\tt aVout} is not initialized or +! if any of the specified attributes are not present in either {\tt aVout} or {\tt aVin}. +! +! !REVISION HISTORY: +! 2002 Sep 15 - ? - initial version. +! 2013-Jul-20 - T. Craig -- updated +! +! !INTERFACE: ------------------------------------------------------------------ + + subroutine mct_avect_accum(aVin, aVout, rList, TrList, iList, TiList, vector, sharedIndices,counter) + + implicit none + +! !INPUT PARAMETERS: + + type(mct_avect), intent(in) :: aVin + character(len=*), optional, intent(in) :: iList + character(len=*), optional, intent(in) :: rList + character(len=*), optional, intent(in) :: TiList + character(len=*), optional, intent(in) :: TrList + logical, optional, intent(in) :: vector + type(mct_avect_SharedIndices), optional, intent(in) :: sharedIndices + +! !OUTPUT PARAMETERS: + + type(mct_avect), intent(inout) :: aVout + integer, optional, intent(inout) :: counter + + +! !REVISION HISTORY: + +!EOP ___________________________________________________________________ + + !--- local --- + logical :: usevector + integer(IN) :: lsize,nflds,npts,i,j + type(mct_avect) :: avotmp ! temporary aVout copy + character(*),parameter :: subName = '(mct_aVect_accum) ' + +!----------------------------------------------------------------- + + usevector = .false. + if (present(vector)) then + usevector = vector + endif + + if (present(counter)) then + counter = counter + 1 + endif + + ! --- allocate avotmp, a duplciate of aVout + + lsize = mct_aVect_lsize(aVout) + call mct_avect_init(avotmp,aVout,lsize) + call mct_avect_zero(avotmp) + + ! --- copy aVin fields into avotmp + + if (present(sharedIndices)) then + + if (present(rList) .and. present(iList)) then + if (present(trList) .and. present(tilist)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, iList, tiList, vector = usevector, sharedIndices=sharedIndices) + elseif (present(trList)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, iList, vector = usevector, sharedIndices=sharedIndices) + elseif (present(tiList)) then + call mct_avect_copy(aVin, avotmp, rList, iList=iList, tiList=tiList, vector = usevector, sharedIndices=sharedIndices) + else + call mct_avect_copy(aVin, avotmp, rList=rList, iList=iList, vector = usevector, sharedIndices=sharedIndices) + endif + else if (present(rList)) then + if (present(trList)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, vector = usevector, sharedIndices=sharedIndices) + else + call mct_avect_copy(aVin, avotmp, rList, vector = usevector, sharedIndices=sharedIndices) + endif + + else if (present(iList)) then + if (present(tiList)) then + call mct_avect_copy(aVin, avotmp, ilist=iList, tiList=tiList, vector = usevector, sharedIndices=sharedIndices) + else + call mct_avect_copy(aVin, avotmp, ilist=iList, vector = usevector, sharedIndices=sharedIndices) + endif + + else + call mct_avect_copy(aVin, avotmp, vector=usevector, sharedIndices=sharedIndices) + + endif + + else ! sharedIndices + + if (present(rList) .and. present(iList)) then + if (present(trList) .and. present(tilist)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, iList, tiList, vector = usevector) + elseif (present(trList)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, iList, vector = usevector) + elseif (present(tiList)) then + call mct_avect_copy(aVin, avotmp, rList, iList=iList, tiList=tiList, vector = usevector) + else + call mct_avect_copy(aVin, avotmp, rList=rList, iList=iList, vector = usevector) + endif + else if (present(rList)) then + if (present(trList)) then + call mct_avect_copy(aVin, avotmp, rList, TrList, vector = usevector) + else + call mct_avect_copy(aVin, avotmp, rList, vector = usevector) + endif + + else if (present(iList)) then + if (present(tiList)) then + call mct_avect_copy(aVin, avotmp, ilist=iList, tiList=tiList, vector = usevector) + else + call mct_avect_copy(aVin, avotmp, ilist=iList, vector = usevector) + endif + + else + call mct_avect_copy(aVin, avotmp, vector=usevector) + + endif + + endif ! shared indices + + ! --- accumulate avotmp into avout + + nflds = mct_aVect_nRAttr(aVout) + npts = mct_aVect_lsize (aVout) +!DIR$ CONCURRENT +!DIR$ PREFERVECTOR + do i=1,npts + do j=1,nflds + aVout%rattr(j,i) = aVout%rattr(j,i) + avotmp%rattr(j,i) + enddo + enddo + + ! --- clean avotmp + + call mct_avect_clean(avotmp) + + end subroutine mct_avect_accum + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_aVect_avg - averages an accumulated attribute vector +! +! !DESCRIPTION: +! Average the data in attribute vector {\tt aVect}. Divides all fields in +! the attribute vector {\tt aVect} by the value of the input counter. +! +! !REVISION HISTORY: +! 2002-Sep-15 - T. Craig -- initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_aVect_avg(aVect, counter) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect),intent(inout) :: aVect ! bundle to read + integer ,intent(in) :: counter ! counter + +!EOP + + !--- local --- + integer(IN) :: i,j ! generic indicies + integer(IN) :: npts ! number of points (local) in an aVect field + integer(IN) :: nflds ! number of aVect fields (real) + real(R8) :: ravg ! accumulation count + + !--- formats --- + character(*),parameter :: subName = '(mct_aVect_avg) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (counter == 0 .or. counter == 1) return + + ravg = 1.0_R8/real(counter,R8) + + nflds = mct_aVect_nRAttr(aVect) + npts = mct_aVect_lsize (aVect) +!DIR$ CONCURRENT +!DIR$ PREFERVECTOR + do i=1,npts + do j=1,nflds + aVect%rattr(j,i) = aVect%rattr(j,i)*ravg + enddo + enddo + +end subroutine mct_aVect_avg + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_avect_mult - multiply an attribute vector by a field. +! +! !DESCRIPTION: +! Replace each field in {\tt av} by the product of that field and the +! field {\tt fld1} from input argument {\tt av1}. +! +! If optional argument {\tt bunlist} is present, only those attributes +! in {\tt bun} will be replaced. +! +! If optional argument {\tt initav} is present, then the data in {\tt av} +! is replaced by the product of the data in {\tt initav} and {\tt fld1} +! from {\tt av1}. NOTE: this assume {\tt initav} has the exact same +! attributes in the same order as {\tt av}. +! +! +! !REVISION HISTORY: +! 2007-Jun-11 - M. Vertenstein -- initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_avect_mult(av,av1,fld1,avlist) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) ,intent(inout) :: av ! attribute vector output + type(mct_aVect) ,intent(in) :: av1 ! attribute vector input + character(*) ,intent(in) :: fld1 ! av1 field name + character(*),optional,intent(in) :: avlist ! sublist of field in av + +!EOP + + !--- local --- + integer(IN) :: n,m ! generic indicies + integer(IN) :: npts ! number of points (local) in an aVect field + integer(IN) :: nfld ! number of fields (local) in an aVect field + integer(IN) :: nfldi ! number of fields (local) in an aVect field + integer(IN) :: nptsx ! number of points (local) in an aVect field + integer(IN) :: nptsi ! number of points (local) in an aVect field + integer(IN) :: kfld ! field number of fld1 in av1 + integer(IN),dimension(:),allocatable :: kfldin ! field numbers of avlist in av + type(mct_list) :: blist ! avlist as a List + type(mct_string) :: tattr ! an attribute + + !--- formats --- + character(*),parameter :: subName = '(mct_aVect_mult) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + nptsx = mct_aVect_lsize(av1) + npts = mct_aVect_lsize(av) + if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx + + kfld = mct_aVect_indexRA(av1,fld1,perrWith=subName) + + if (present(avlist)) then + + call mct_list_init(blist,avlist) + + nfld=mct_list_nitem(blist) + + allocate(kfldin(nfld)) + do m=1,nfld + call mct_list_get(tattr,m,blist) + kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr)) + call mct_string_clean(tattr) + enddo + call mct_list_clean(blist) + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*av1%rAttr(kfld,n) + enddo + enddo + + deallocate(kfldin) + + else + + nfld = mct_aVect_nRAttr(av) + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + av%rAttr(m,n) = av%rAttr(m,n)*av1%rAttr(kfld,n) + enddo + enddo + + endif + +end subroutine mct_aVect_mult + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: mct_avect_vecmult - multiply an attribute vector by a field. +! +! !DESCRIPTION: +! Replace each field in {\tt av} by the product of that field and the +! field {\tt fld1} from input argument {\tt av1}. +! +! If optional argument {\tt bunlist} is present, only those attributes +! in {\tt bun} will be replaced. +! +! If optional argument {\tt initav} is present, then the data in {\tt av} +! is replaced by the product of the data in {\tt initav} and {\tt fld1} +! from {\tt av1}. NOTE: this assume {\tt initav} has the exact same +! attributes in the same order as {\tt av}. +! +! +! !REVISION HISTORY: +! 2007-Jun-11 - M. Vertenstein -- initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine mct_avect_vecmult(av,vec,avlist,mask_spval) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) ,intent(inout) :: av ! attribute vector output + real(R8) ,intent(in) :: vec(:) + character(*),optional,intent(in) :: avlist ! sublist of field in av + logical, optional ,intent(in) :: mask_spval + +!EOP + + !--- local --- + integer(IN) :: n,m ! generic indicies + integer(IN) :: npts ! number of points (local) in an aVect field + integer(IN) :: nfld ! number of fields (local) in an aVect field + integer(IN) :: nfldi ! number of fields (local) in an aVect field + integer(IN) :: nptsx ! number of points (local) in an aVect field + integer(IN) :: nptsi ! number of points (local) in an aVect field + logical :: lmspval ! local mask spval + integer(IN),dimension(:),allocatable :: kfldin ! field numbers of avlist in av + type(mct_list) :: blist ! avlist as a List + type(mct_string) :: tattr ! an attribute + + !--- formats --- + character(*),parameter :: subName = '(mct_aVect_vecmult) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lmspval = .false. + if (present(mask_spval)) then + lmspval = mask_spval + endif + + nptsx = size(vec,1) + npts = mct_aVect_lsize(av) + if (nptsx /= npts .and. s_loglev > 0) write(s_logunit,*) subName,' ERROR: npts error1 ',npts,nptsx + + + if (present(avlist)) then + + call mct_list_init(blist,avlist) + + nfld=mct_list_nitem(blist) + + allocate(kfldin(nfld)) + do m=1,nfld + call mct_list_get(tattr,m,blist) + kfldin(m) = mct_aVect_indexRA(av,mct_string_toChar(tattr)) + call mct_string_clean(tattr) + enddo + call mct_list_clean(blist) + + if (lmspval) then + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + if (.not. shr_const_isspval(av%rAttr(kfldin(m),n))) then + av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*vec(n) + endif + enddo + enddo + + else ! lmspval + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + av%rAttr(kfldin(m),n) = av%rAttr(kfldin(m),n)*vec(n) + enddo + enddo + + endif ! lmspval + + deallocate(kfldin) + + else ! avlist + + nfld = mct_aVect_nRAttr(av) + + if (lmspval) then + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + if (.not. shr_const_isspval(av%rAttr(m,n))) then + av%rAttr(m,n) = av%rAttr(m,n)*vec(n) + endif + enddo + enddo + + else ! lmspval + +#ifdef CPP_VECTOR + do m=1,nfld +!CDIR SELECT(VECTOR) +!DIR$ CONCURRENT + do n=1,npts +#else + do n=1,npts + do m=1,nfld +#endif + av%rAttr(m,n) = av%rAttr(m,n)*vec(n) + enddo + enddo + + endif ! lmspval + + endif ! avlist + +end subroutine mct_aVect_vecmult + +!=============================================================================== +! !BOP =========================================================================== +! +! !IROUTINE: subroutine mct_rearr_rearrange_fldlst - rearrange on a fieldlist +! +! !DESCRIPTION: +! Perform regarranger between two attribute vectors only on the fieldlist +! that is provided +! +! +! !REVISION HISTORY: +! 2007-Jun-22 - M. Vertenstein - first version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine mct_rearr_rearrange_fldlist(avi, avo, Rearr, vector, alltoall, fldlist, tag) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_aVect) , intent(in) :: avi + type(mct_aVect) , intent(inout):: avo + type(mct_rearr) , intent(in) :: Rearr + logical , intent(in) :: vector + logical , intent(in) :: alltoall + character(len=*), intent(in) :: fldlist + integer(IN) , intent(in),optional :: tag +! !EOP + + !---local --- + type(mct_aVect) :: avi_fl + type(mct_aVect) :: avo_fl + integer(IN) :: lsize + integer(IN) :: ltag + + !--- formats --- + character(*),parameter :: subName = '(mct_rearr_rearrange_fldlist) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (present(tag)) then + ltag = tag + else + ltag = 3000 + endif + + lsize = mct_aVect_lsize(avi) + call mct_aVect_init (avi_fl, rlist=fldlist, lsize=lsize) + call mct_aVect_zero (avi_fl) + + lsize = mct_aVect_lsize(avo) + call mct_aVect_init (avo_fl, rlist=fldlist, lsize=lsize) + call mct_aVect_zero (avo_fl) + + call mct_aVect_copy (aVin=avi, aVout=avi_fl) + call mct_rearr_rearrange(avi_fl, avo_fl, Rearr, VECTOR=vector, ALLTOALL=alltoall, tag=ltag) + call mct_aVect_copy (aVin=avo_fl, aVout=avo, vector=vector) + + call mct_aVect_clean(avi_fl) + call mct_aVect_clean(avo_fl) + +end subroutine mct_rearr_rearrange_fldlist + +!======================================================================= +logical function mct_gsmap_Identical(gsmap1,gsmap2) + + implicit none + type(mct_gsMap), intent(IN):: gsmap1 + type(mct_gsMap), intent(IN):: gsmap2 + + ! Local variables + + character(len=*),parameter :: subname = "(mct_gsmap_Identical) " + integer :: n + logical :: identical + + !----------------------- + + identical = .true. + + ! --- continue compare --- + if (identical) then + if (mct_gsMap_gsize(gsmap1) /= mct_gsMap_gsize(gsmap2)) identical = .false. + if (mct_gsMap_ngseg(gsmap1) /= mct_gsMap_ngseg(gsmap2)) identical = .false. + endif + + ! --- continue compare --- + if (identical) then + do n = 1,mct_gsMap_ngseg(gsmap1) + if (gsmap1%start(n) /= gsmap2%start(n) ) identical = .false. + if (gsmap1%length(n) /= gsmap2%length(n)) identical = .false. + if (gsmap1%pe_loc(n) /= gsmap2%pe_loc(n)) identical = .false. + enddo + endif + + mct_gsmap_Identical = identical + +end function mct_gsmap_Identical + +!=============================================================================== +! !BOP =========================================================================== +! +! !IROUTINE: mct_myindex - binary search for index in list +! +! !DESCRIPTION: +! Do a binary search to see if a value is contained in a list of +! values. return true or false. starti must be monotonically +! increasing, function does NOT check this. +! +! +! !REVISION HISTORY: +! 2007-Jan-17 - T. Craig -- first version +! 2007-Mar-20 - R. Jacob - move to mct_mod +! +! !INTERFACE: ----------------------------------------------------------------- + +logical function mct_myindex(index,starti,counti) + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + integer(IN) :: index ! is this index in start/count list + integer(IN) :: starti(:) ! start list + integer(IN) :: counti(:) ! count list + +! !EOP + + !--- local --- + integer(IN) :: nl,nc,nr,ncprev + integer(IN) :: lsize + logical :: stopnow + + !--- formats --- + character(*),parameter :: subName = '(mct_myindex) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + mct_myindex = .false. + + lsize = size(starti) + if (lsize < 1) return + + nl = 0 + nr = lsize + 1 + nc = (nl+nr)/2 + stopnow = .false. + do while (.not.stopnow) + if (index < starti(nc)) then + nr = nc + elseif (index > (starti(nc) + counti(nc) - 1)) then + nl = nc + else + mct_myindex = .true. + return + endif + ncprev = nc + nc = (nl + nr)/2 + if (nc == ncprev .or. nc < 1 .or. nc > lsize) stopnow = .true. + enddo + + mct_myindex = .false. + return + +end function mct_myindex +!=============================================================================== + +end module mct_mod + diff --git a/share/csm_share/shr/shr_assert_mod.F90.in b/share/csm_share/shr/shr_assert_mod.F90.in new file mode 100644 index 000000000000..1dce64b1157a --- /dev/null +++ b/share/csm_share/shr/shr_assert_mod.F90.in @@ -0,0 +1,407 @@ +module shr_assert_mod + +! Assert subroutines for common debugging operations. + +use shr_kind_mod, only: & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + i4 => shr_kind_i4, & + i8 => shr_kind_i8 + +use shr_sys_mod, only: & + shr_sys_abort + +use shr_log_mod, only: & + shr_log_Unit + +use shr_infnan_mod, only: shr_infnan_isnan + +implicit none +private +save + +! Assert that a logical is true. +public :: shr_assert +public :: shr_assert_all +public :: shr_assert_any + +! Assert that a numerical value satisfies certain constraints. +public :: shr_assert_in_domain + +interface shr_assert_all + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_all_{DIMS}d +end interface + +interface shr_assert_any + module procedure shr_assert + ! DIMS 1,2,3,4,5,6,7 + module procedure shr_assert_any_{DIMS}d +end interface + +interface shr_assert_in_domain + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure shr_assert_in_domain_{DIMS}d_{TYPE} +end interface + +! Private utilities. + +interface print_bad_loc + ! TYPE double,real,int,long + ! DIMS 0,1,2,3,4,5,6,7 + module procedure print_bad_loc_{DIMS}d_{TYPE} +end interface + +interface find_first_loc + ! DIMS 0,1,2,3,4,5,6,7 + module procedure find_first_loc_{DIMS}d +end interface + +interface within_tolerance + ! TYPE double,real,int,long + module procedure within_tolerance_{TYPE} +end interface + +contains + +subroutine shr_assert(var, msg) + + ! Logical being asserted. + logical, intent(in) :: var + ! Optional error message if assert fails. + character(len=*), intent(in) :: msg + + if (.not. var) call shr_sys_abort(msg) + +end subroutine shr_assert + +! DIMS 1,2,3,4,5,6,7 +subroutine shr_assert_all_{DIMS}d(var, msg) + + ! Logical being asserted. + logical, intent(in) :: var{DIMSTR} + ! Optional error message if assert fails. + character(len=*), intent(in) :: msg + + call shr_assert(all(var), msg) + +end subroutine shr_assert_all_{DIMS}d + +! DIMS 1,2,3,4,5,6,7 +subroutine shr_assert_any_{DIMS}d(var, msg) + + ! Logical being asserted. + logical, intent(in) :: var{DIMSTR} + ! Optional error message if assert fails. + character(len=*), intent(in) :: msg + + call shr_assert(any(var), msg) + +end subroutine shr_assert_any_{DIMS}d + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +subroutine shr_assert_in_domain_{DIMS}d_{TYPE}(var, varname, msg, & + is_nan, lt, gt, le, ge, eq, ne, abs_tol) + +!----------------------------- +! BEGIN defining local macros +!----------------------------- + +! Flag for floating point types. + +#if ({ITYPE} == TYPEREAL) || ({ITYPE} == TYPEDOUBLE) +#define TYPEFP +#else +#undef TYPEFP +#endif + +! "Generalized" macro functions allow transformational intrinsic functions +! to handle both scalars and arrays. + +#if ({DIMS} != 0) +! When given an array, use the intrinsics. +#define GEN_SIZE(x) size(x) +#define GEN_ALL(x) all(x) +#else + +! Scalar extensions: +! GEN_SIZE always returns 1 for a scalar. +! GEN_ALL (logical reduction) is a no-op for a scalar. +! GEN_[MAX,MIN]LOC should return a 1D, size 0 (empty), integer array. +#define GEN_SIZE(x) 1 +#define GEN_ALL(x) x + +#endif + +!----------------------------- +! END macro section +!----------------------------- + + ! Variable being checked. + {VTYPE}, intent(in) :: var{DIMSTR} + ! Variable name to be used in error messages. + character(len=*), intent(in), optional :: varname + ! Optional error message if assert fails. + character(len=*), intent(in), optional :: msg + ! Assert that the variable is not (or is) NaN. + logical, intent(in), optional :: is_nan + ! Limits for (in)equalities. + {VTYPE}, intent(in), optional :: lt + {VTYPE}, intent(in), optional :: gt + {VTYPE}, intent(in), optional :: le + {VTYPE}, intent(in), optional :: ge + {VTYPE}, intent(in), optional :: eq + {VTYPE}, intent(in), optional :: ne + {VTYPE}, intent(in), optional :: abs_tol + + ! Note that the following array is size 0 for scalars. + integer :: loc_vec({DIMS}) + + logical :: is_nan_passed + logical :: lt_passed + logical :: gt_passed + logical :: le_passed + logical :: ge_passed + logical :: eq_passed + logical :: ne_passed + + {VTYPE} :: abs_tol_loc + + ! Handling of abs_tol makes a couple of fairly safe assumptions. + ! 1. It is not the most negative integer. + ! 2. It is finite (not a floating point infinity or NaN). + if (present(abs_tol)) then + abs_tol_loc = abs(abs_tol) + else + abs_tol_loc = 0_i4 + end if + + is_nan_passed = .true. + lt_passed = .true. + gt_passed = .true. + le_passed = .true. + ge_passed = .true. + eq_passed = .true. + ne_passed = .true. + + ! Do one pass just to find out if we can return with no problem. + +#ifdef TYPEFP + ! Only floating-point values can actually be Inf/NaN. + if (present(is_nan)) & + is_nan_passed = GEN_ALL(shr_infnan_isnan(var) .eqv. is_nan) +#else + if (present(is_nan)) & + is_nan_passed = .not. is_nan .or. GEN_SIZE(var) == 0 +#endif + + if (present(lt)) & + lt_passed = GEN_ALL(var < lt) + + if (present(gt)) & + gt_passed = GEN_ALL(var > gt) + + if (present(le)) & + le_passed = GEN_ALL(var <= le) + + if (present(ge)) & + ge_passed = GEN_ALL(var >= ge) + + if (present(eq)) then + eq_passed = GEN_ALL(within_tolerance(eq, var, abs_tol_loc)) + end if + + if (present(ne)) then + ne_passed = GEN_ALL(.not. within_tolerance(ne, var, abs_tol_loc)) + end if + + if ( is_nan_passed .and. & + lt_passed .and. & + gt_passed .and. & + le_passed .and. & + ge_passed .and. & + eq_passed .and. & + ne_passed) & + return + + ! If we got here, assert will fail, so find out where so that we + ! can try to print something useful. + + if (.not. is_nan_passed) then +#ifdef TYPEFP + loc_vec = find_first_loc(shr_infnan_isnan(var) .neqv. is_nan) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) "Expected value to be NaN." + else + write(shr_log_Unit,*) "Expected value to be a number." + end if +#else + loc_vec = spread(1,1,{DIMS}) + call print_bad_loc(var, loc_vec, varname) + if (is_nan) then + write(shr_log_Unit,*) & + "Asserted NaN, but the variable is not floating-point!" + end if +#endif + end if + + if (.not. lt_passed) then + loc_vec = find_first_loc(var >= lt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than ",lt + end if + + if (.not. gt_passed) then + loc_vec = find_first_loc(var <= gt) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than ",gt + end if + + if (.not. le_passed) then + loc_vec = find_first_loc(var > le) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be less than or & + &equal to ",le + end if + + if (.not. ge_passed) then + loc_vec = find_first_loc(var < ge) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be greater than or & + &equal to ",ge + end if + + if (.not. eq_passed) then + loc_vec = find_first_loc(.not. within_tolerance(eq, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to be equal to ",eq + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + if (.not. ne_passed) then + loc_vec = find_first_loc(within_tolerance(ne, var, abs_tol_loc)) + call print_bad_loc(var, loc_vec, varname) + write(shr_log_Unit,*) "Expected value to never be equal to ",ne + if (abs_tol_loc > 0) & + write(shr_log_Unit,*) "Asserted with tolerance ", abs_tol_loc + end if + + call shr_sys_abort(msg) + +! Undefine local macros. +#undef TYPEFP +#undef GEN_SIZE +#undef GEN_ALL + +end subroutine shr_assert_in_domain_{DIMS}d_{TYPE} + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! TYPE double,real,int,long +! DIMS 0,1,2,3,4,5,6,7 +subroutine print_bad_loc_{DIMS}d_{TYPE}(var, loc_vec, varname) + ! Print information about a bad location in an variable. + ! For scalars, just print value. + + {VTYPE}, intent(in) :: var{DIMSTR} + integer, intent(in) :: loc_vec({DIMS}) + + character(len=*), intent(in), optional :: varname + + character(len=:), allocatable :: varname_to_write + + if (present(varname)) then + allocate(varname_to_write, source=varname) + else + allocate(varname_to_write, source="input variable") + end if + + write(shr_log_Unit,*) & + "ERROR: shr_assert_in_domain: ",trim(varname_to_write), & + " has invalid value ", & +#if ({DIMS} != 0) + var({REPEAT:loc_vec(#)}), & + " at location: ",loc_vec +#else + var + + ! Kill compiler spam for unused loc_vec. + if (.false.) write(*,*) loc_vec +#endif + +end subroutine print_bad_loc_{DIMS}d_{TYPE} + +!-------------------------------------------------------------------------- +!-------------------------------------------------------------------------- + +! DIMS 0,1,2,3,4,5,6,7 +pure function find_first_loc_{DIMS}d(mask) result (loc_vec) + ! Inefficient but simple subroutine for finding the location of + ! the first .true. value in an array. + ! If no true values, returns first value. + + logical, intent(in) :: mask{DIMSTR} + integer :: loc_vec({DIMS}) + +#if ({DIMS} != 0) + integer :: flags({REPEAT:size(mask,#)}) + + where (mask) + flags = 1 + elsewhere + flags = 0 + end where + + loc_vec = maxloc(flags) +#else + +! Remove compiler warnings (statement will be optimized out). + +#if (! defined CPRPGI && ! defined CPRCRAY) + if (.false. .and. mask) loc_vec = loc_vec +#endif + +#endif + +end function find_first_loc_{DIMS}d + +! TYPE double,real,int,long +elemental function within_tolerance_{TYPE}(expected, actual, tolerance) & + result(is_in_tol) + ! Precondition: tolerance must be >= 0. + {VTYPE}, intent(in) :: expected + {VTYPE}, intent(in) :: actual + {VTYPE}, intent(in) :: tolerance + logical :: is_in_tol + + ! The following conditionals are to ensure that we don't overflow. + + ! This takes care of two identical infinities. + if (actual == expected) then + is_in_tol = .true. + else if (actual > expected) then + if (expected >= 0) then + is_in_tol = (actual - expected) <= tolerance + else + is_in_tol = actual <= (expected + tolerance) + end if + else + if (expected < 0) then + is_in_tol = (expected - actual) <= tolerance + else + is_in_tol = actual >= (expected - tolerance) + end if + end if + +end function within_tolerance_{TYPE} + +end module shr_assert_mod diff --git a/share/csm_share/shr/shr_cal_mod.F90 b/share/csm_share/shr/shr_cal_mod.F90 new file mode 100644 index 000000000000..dc52ed886b74 --- /dev/null +++ b/share/csm_share/shr/shr_cal_mod.F90 @@ -0,0 +1,934 @@ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_cal_mod -- calendar module, relates elapsed days to calendar date. +! +! !DESCRIPTION: +! These calendar routines do conversions between... +! \begin{itemize} +! \item the integer number of elapsed days +! \item the integers year, month, day (three inter-related integers) +! \item the integer coded calendar date (yyyymmdd) +! \end{itemize} +! Possible uses include: a calling routine can increment the elapsed days +! integer and use this module to determine what the corresponding calendar +! date is; this module can be used to determine how many days apart two +! arbitrary calendar dates are. +! +! !REVISION HISTORY: +! 2001-dec-28 - B. Kauffman - created initial version, taken from cpl5 +! 2012-feb-10 - T. Craig - update to esmf 5.2.0rp1, some noleap functions +! associated with elapsed days must still be done internally +! +! !REMARKS: +! Following are some internal assumptions. These assumptions are somewhat +! arbitrary -- they were chosen because they result in the simplest code given +! the requirements of this module. These assumptions can be relaxed as +! necessary: +! o the valid range of years is [-999,9999] +! o elapsed days = 0 <=> January 1st, year 0000 for noleap +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_cal_mod + +! !USES: + + use shr_kind_mod ! kinds + use shr_const_mod ! constants + use shr_sys_mod ! system + use shr_string_mod, only: shr_string_toLower + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use esmf + + implicit none + + private ! except + +! !PUBLIC TYPES: + + type, public :: calParamType + ! parameters to replace use of numbers for dates in code + + ! We'd like to have these be parameters, but then they + ! can't be part of a derived type + integer :: january = 1 + integer :: february = 2 + integer :: march = 3 + integer :: april = 4 + integer :: may = 5 + integer :: june = 6 + integer :: july = 7 + integer :: august = 8 + integer :: september = 9 + integer :: october = 10 + integer :: november = 11 + integer :: december = 12 + integer :: firstDayOfMonth = 1 + end type calParamType + + ! Instance of calender parameters as a protected type so can't change outside this module + type(calParamType), public, protected :: calParams + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_cal_calendarName ! checks and returns valid cal name + public :: shr_cal_numDaysinMonth ! number of days in a month + public :: shr_cal_numDaysinYear ! number of days in a year + public :: shr_cal_elapsDaysStrtMonth ! elapsed days on start of month + public :: shr_cal_timeset ! set ESMF Time from ymd, s, shr_cal calendar + public :: shr_cal_date2ymd ! converts coded-date to yr,month,day + public :: shr_cal_date2julian! converts coded-date,sec to julian days + public :: shr_cal_ymd2julian ! converts yr,month,day,sec to julian days + public :: shr_cal_ymd2date ! converts yr,month,day to coded-date + public :: shr_cal_advDate ! advance date/secs real seconds + public :: shr_cal_advDateInt ! advance date/secs integer seconds + public :: shr_cal_validDate ! logical function: is coded-date valid? + public :: shr_cal_validYMD ! logical function: are yr,month,day valid? + public :: shr_cal_validHMS ! logical function: are hr, min, sec valid? + public :: shr_cal_getDebug ! get internal debug level + public :: shr_cal_setDebug ! set internal debug level + +! !PUBLIC DATA MEMBERS: + + ! none + +!EOP + + integer(SHR_KIND_IN),parameter,public :: shr_cal_calMaxLen = 64 + character(len=*),parameter,public :: & + shr_cal_noleap = 'NO_LEAP', & + shr_cal_gregorian = 'GREGORIAN' + + !--- trigger internal debug output --- + integer(SHR_KIND_IN) :: debug = 0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +contains +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_calendarName - check calendar name and translate +! +! !DESCRIPTION: +! Check the validity of the calendar name and translate to standard naming +! +! !REVISION HISTORY: +! 2010-oct-7 - T Craig - initial version. +! +! !INTERFACE: ----------------------------------------------------------------- + +function shr_cal_calendarName(calendar,trap) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: calendar ! calendar type + logical ,optional,intent(in) :: trap + character(len=shr_cal_calMaxLen) :: shr_cal_calendarName + +!EOP + + character(len=shr_cal_calMaxLen) :: lcal + logical :: ltrap + character(len=shr_cal_calMaxLen) :: lowercalendar + character(*),parameter :: subName = "(shr_cal_calendarName)" + + ltrap = .true. + if (present(trap)) then + ltrap = trap + endif + + lcal = ' ' + lowercalendar = trim(shr_string_toLower(trim(calendar))) + lcal = trim(calendar) + + selectcase(trim(lowercalendar)) + + case ('noleap') + lcal = trim(shr_cal_noleap) + case ('no_leap') + lcal = trim(shr_cal_noleap) + case ('365_day') + lcal = trim(shr_cal_noleap) + case ('365day') + lcal = trim(shr_cal_noleap) + case ('gregorian') + lcal = trim(shr_cal_gregorian) + case ('standard') + lcal = trim(shr_cal_gregorian) + case ('proleptic_gregorian') + lcal = trim(shr_cal_gregorian) + case default + if (ltrap) then + write(s_logunit,*) trim(subname),' : ERROR calendar not supported : ',trim(calendar) + call shr_sys_abort(trim(subname)//' : calendar not supported : '//trim(calendar)) + endif + end select + + shr_cal_calendarName = trim(lcal) + + end function shr_cal_calendarName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_timeSet - create and esmf_time type for ymd, sec and calendar +! +! !DESCRIPTION: +! Create ESMF_Time type from ymd, sec, calendar +! +! !REVISION HISTORY: +! 2012-feb-10 - T. Craig - initial version. +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_timeSet(etime,ymd,sec,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(ESMF_Time),intent(out) :: etime + integer(SHR_KIND_IN),intent(in ) :: ymd,sec ! ymd, sec + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + integer(SHR_KIND_IN) :: year,month,day + type(ESMF_CALKIND_FLAG) :: calkind + character(len=shr_cal_calMaxLen) :: lcalendar + integer :: rc + character(*),parameter :: subName = "(shr_cal_timeSet)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + + lcalendar = shr_cal_calendarName(calendar) + + calkind = ESMF_CALKIND_NOLEAP + if (trim(lcalendar) == trim(shr_cal_gregorian)) then + calkind = ESMF_CALKIND_GREGORIAN + endif + + call shr_cal_date2ymd(ymd,year,month,day) + call ESMF_TimeSet(etime,yy=year,mm=month,dd=day,s=sec,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + +end subroutine shr_cal_timeSet +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_numDaysInMonth - return the number of days in a month. +! +! !DESCRIPTION: +! Deturn the number of days in a month. +! +! !REVISION HISTORY: +! 2002-sep-18 - B. Kauffman - initial version. +! +! !INTERFACE: ----------------------------------------------------------------- + +integer function shr_cal_numDaysInMonth(year,month,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year,month ! calendar year,month + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + type(ESMF_time) :: time1,time2 + type(ESMF_timeInterval) :: timeint + type(ESMF_CALKIND_FLAG) :: calkind + integer(SHR_KIND_IN) :: eday + character(len=shr_cal_calMaxLen) :: lcalendar + integer :: rc + character(*),parameter :: subName = "(shr_cal_numDaysInMonth)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lcalendar = shr_cal_calendarName(calendar) + + calkind = ESMF_CALKIND_NOLEAP + if (trim(lcalendar) == trim(shr_cal_gregorian)) then + calkind = ESMF_CALKIND_GREGORIAN + endif + + call ESMF_TimeSet(time1,yy=year,mm=month,dd=1,s=0,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + if (month < 12) then + call ESMF_TimeSet(time2,yy=year,mm=month+1,dd=1,s=0,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + else + call ESMF_TimeSet(time2,yy=year+1,mm=1,dd=1,s=0,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + endif + timeint = time2-time1 + call ESMF_TimeIntervalGet(timeint,StartTimeIn=time1,d=eday) + shr_cal_numDaysInMonth = eday + +end function shr_cal_numDaysInMonth + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_numDaysInYear - return the number of days in a year. +! +! !DESCRIPTION: +! Deturn the number of days in a year. +! +! !REVISION HISTORY: +! 2002-sep-18 - B. Kauffman - initial version. +! +! !INTERFACE: ----------------------------------------------------------------- + +integer function shr_cal_numDaysInYear(year,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year ! calendar year + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + type(ESMF_time) :: time1,time2 + type(ESMF_timeInterval) :: timeint + type(ESMF_CALKIND_FLAG) :: calkind + integer(SHR_KIND_IN) :: eday + character(len=shr_cal_calMaxLen) :: lcalendar + integer :: rc + character(*),parameter :: subName = "(shr_cal_numDaysInYear)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lcalendar = shr_cal_calendarName(calendar) + + calkind = ESMF_CALKIND_NOLEAP + if (trim(lcalendar) == trim(shr_cal_gregorian)) then + calkind = ESMF_CALKIND_GREGORIAN + endif + + call ESMF_TimeSet(time1,yy=year,mm=1,dd=1,s=0,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + call ESMF_TimeSet(time2,yy=year+1,mm=1,dd=1,s=0,calkindflag=calkind,rc=rc) + if(rc /= ESMF_SUCCESS) call ESMF_Finalize(rc=rc, endflag=ESMF_END_ABORT) + timeint = time2-time1 + call ESMF_TimeIntervalGet(timeint,StartTimeIn=time1,d=eday) + shr_cal_numDaysInYear = eday + +end function shr_cal_numDaysInYear + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_elapsDaysStrtMonth - return the number of elapsed days +! at start of month +! +! !DESCRIPTION: +! Return the number of elapsed days at start of a month. +! +! !REVISION HISTORY: +! 2002-Oct-29 - R. Jacob - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +integer function shr_cal_elapsDaysStrtMonth(year,month,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year,month ! calendar year,month + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + integer :: rc + integer :: k + character(*),parameter :: subName = "(shr_cal_elapsDaysStrtMonth)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + shr_cal_elapsDaysStrtMonth = 0 + do k = 1,month-1 + shr_cal_elapsDaysStrtMonth = shr_cal_elapsDaysStrtMonth + & + shr_cal_numDaysInMonth(year,k,calendar) + enddo + +end function shr_cal_elapsDaysStrtMonth + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_date2ymd - converts coded-date to year/month/day. +! +! !DESCRIPTION: +! Converts coded-date (yyyymmdd) to year/month/day. +! +! !REVISION HISTORY: +! 2001-dec-28 - B. Kauffman - initial version, taken from cpl5 +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_date2ymd (date,year,month,day) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: date ! coded-date (yyyymmdd) + integer(SHR_KIND_IN),intent(out) :: year,month,day ! calendar year,month,day + +!EOP + + integer(SHR_KIND_IN) :: tdate ! temporary date + character(*),parameter :: subName = "(shr_cal_date2ymd)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (debug > 1) write(s_logunit,*) trim(subname),'_a ',date + + tdate = abs(date) + year =int( tdate /10000) + if (date < 0) year = -year + month=int( mod(tdate,10000)/ 100) + day = mod(tdate, 100) + + if (debug > 1) write(s_logunit,*) trim(subname),'_b ',year,month,day + +end subroutine shr_cal_date2ymd + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_date2julian - converts coded-date to julian day of year +! +! !DESCRIPTION: +! Converts coded-date to julian day of year +! +! !REVISION HISTORY: +! 2009-Oct-23 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_date2julian(date,sec,jday,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: date ! coded (yyyymmdd) calendar date + integer(SHR_KIND_IN),intent(in ) :: sec ! seconds + real (SHR_KIND_R8),intent(out) :: jday ! julian day of year + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: year,month,day + character(*),parameter :: subName = "(shr_cal_date2julian)" + +!------------------------------------------------------------------------------- +! NOTE: +! julian day of year since yy-01-01-00000 +!------------------------------------------------------------------------------- + + if (debug > 1) write(s_logunit,*) trim(subname),'_a ',date,sec + + call shr_cal_date2ymd(date,year,month,day) + call shr_cal_ymd2julian(year,month,day,sec,jday,calendar) + + if (debug > 1) write(s_logunit,*) trim(subname),'_b ',jday + +end subroutine shr_cal_date2julian + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_ymd2julian - converts y,m,d,s to julian day of year +! +! !DESCRIPTION: +! Converts y,m,d,s to julian day of year +! +! !REVISION HISTORY: +! 2009-Oct-23 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_ymd2julian(year,month,day,sec,jday,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year ! year + integer(SHR_KIND_IN),intent(in ) :: month ! month + integer(SHR_KIND_IN),intent(in ) :: day ! day + integer(SHR_KIND_IN),intent(in ) :: sec ! seconds + real (SHR_KIND_R8),intent(out) :: jday ! julian day of year + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + !--- local --- + character(*),parameter :: subName = "(shr_cal_ymd2julian)" + +!------------------------------------------------------------------------------- +! NOTE: +! julian day of year since yy-01-01-000000 +!------------------------------------------------------------------------------- + + if (debug > 1) write(s_logunit,*) trim(subname),'_a ',year,month,day,sec + + if (.not. shr_cal_validYMD(year,month,day,calendar)) then + write(s_logunit,*) trim(subname),' ERROR: invalid ymd',year,month,day + call shr_sys_abort(trim(subname)//' ERROR: invalid ymd') + endif + + jday = shr_cal_elapsDaysStrtMonth(year,month,calendar) + day + sec/SHR_CONST_CDAY + + if (debug > 1) write(s_logunit,*) trim(subname),'_b ',jday + +end subroutine shr_cal_ymd2julian + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_ymd2date - converts year, month, day to coded-date +! +! !DESCRIPTION: +! Converts year, month, day to coded-date +! +! !REVISION HISTORY: +! 2001-dec-28 - B. Kauffman - initial version, taken from cpl5 +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_ymd2date(year,month,day,date) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year,month,day ! calendar year,month,day + integer(SHR_KIND_IN),intent(out) :: date ! coded (yyyymmdd) calendar date + +!EOP + + !--- local --- + character(*),parameter :: subName = "(shr_cal_ymd2date)" + +!------------------------------------------------------------------------------- +! NOTE: +! this calendar has a year zero (but no day or month zero) +!------------------------------------------------------------------------------- + + if (debug > 1) write(s_logunit,*) trim(subname),'_a ',year,month,day + + date = abs(year)*10000 + month*100 + day ! coded calendar date + if (year < 0) date = -date + + if (debug > 1) write(s_logunit,*) trim(subname),'_b ',date + +end subroutine shr_cal_ymd2date + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_advDate - advances a date and seconds with a delta time +! +! !DESCRIPTION: +! Advances a date and seconds with a delta time +! Accuracy only good to nearest second +! +! !REVISION HISTORY: +! 2009-Jun-09 - T. Craig - allows delta < 0 +! 2005-Jun-10 - B. Kauffman - bug fix, simplified algorithm +! 2005-May-15 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_advDate(delta,units,dateIN,secIN,dateOUT,secOUT,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + real (SHR_KIND_R8) ,intent(in) :: delta ! time increment + character(*) ,intent(in) :: units ! units of increment + integer(SHR_KIND_IN) ,intent(in) :: dateIN ! base date, yyyymmdd + real (SHR_KIND_R8) ,intent(in) :: secIN ! base seconds + integer(SHR_KIND_IN) ,intent(out) :: dateOUT ! new date, yyyymmdd + real (SHR_KIND_R8) ,intent(out) :: secOUT ! new seconds + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + !--- local --- + type(ESMF_time) :: timeIn, timeOut + type(ESMF_timeInterval) :: dt + real (SHR_KIND_R8) :: dSec ! delta-sec: advance date this many seconds + integer(SHR_KIND_I8) :: i8dsec, i8dday ! delta sec and day in i8 + integer(SHR_KIND_I8) :: spd ! seconds per day in i8 + integer(SHR_KIND_I4) :: idday, idsec ! delta sec and dat in i4 + integer(SHR_KIND_I4) :: year, month, day, sec ! calendar stuff + character(len=shr_cal_calMaxLen) :: lcalendar + type(ESMF_CALKIND_FLAG) :: calkind + + !--- formats --- + character(*),parameter :: subName = "(shr_cal_advDate)" + character(*),parameter :: F00 = "('(shr_cal_advDate) ',a,i5)" + character(*),parameter :: F02 = "('(shr_cal_advDate) ',a,i8.8,f10.3)" + +!------------------------------------------------------------------------------- +! NOTE: +!------------------------------------------------------------------------------- + + !--- calculate delta-time in seconds --- + if (trim(units) == 'days' ) then + dSec = delta * SHR_CONST_CDAY + elseif (trim(units) == 'hours' ) then + dSec = delta * 3600.0_SHR_KIND_R8 + elseif (trim(units) == 'minutes') then + dSec = delta * 60.0_SHR_KIND_R8 + elseif (trim(units) == 'seconds') then + dSec = delta * 1.0_SHR_KIND_R8 + else + call shr_sys_abort(trim(subname)//' ERROR: unrecognized time units '//trim(units)) + endif + + ! take secIn into account here since it's real + dSec = dSec - secIn + + ! i8 math, convert reals to nearest second + i8dSec = nint(dSec,SHR_KIND_I8) + spd = nint(SHR_CONST_CDAY) + i8dday = i8dsec/spd + i8dsec = i8dsec - i8dday*spd + + ! convert to i4 + idday = i8dday + idsec = i8dsec + + calkind = ESMF_CALKIND_NOLEAP + lcalendar = shr_cal_calendarName(calendar) + + if (trim(lcalendar) == trim(shr_cal_gregorian)) then + calkind = ESMF_CALKIND_GREGORIAN + endif + + call shr_cal_date2ymd(dateIn,year,month,day) + call ESMF_TimeSet(timeIN,yy=year,mm=month,dd=day,calkindflag=calkind) + call ESMF_TimeIntervalSet(dt,d=idday,s=idsec) + + timeOut = timeIn + dt + + call ESMF_TimeGet(timeOut,yy=year,mm=month,dd=day,s=sec) + call shr_cal_ymd2date(year,month,day,dateOut) + secOut = sec + + if (debug>0) then + if (s_loglev > 0) write(s_logunit,*) subName," units,delta,calendar=",trim(units),delta,' ',trim(calendar) + if (s_loglev > 0) write(s_logunit,F02) "dateIN ,secIN =",dateIN ,secIN + if (s_loglev > 0) write(s_logunit,F02) "dateOUT,secOUT=",dateOUT,secOUT + end if + +end subroutine shr_cal_advDate + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_advDateInt - advances a date and seconds with a delta time +! +! !DESCRIPTION: +! Advances a date and seconds with a delta time +! +! !REVISION HISTORY: +! 2009-???-?? - ?? - replicated from shr_cal_advDate() +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_cal_advDateInt(delta,units,dateIN,secIN,dateOUT,secOUT,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN) ,intent(in) :: delta ! time increment + character(*) ,intent(in) :: units ! units of increment + integer(SHR_KIND_IN) ,intent(in) :: dateIN ! base date, yyyymmdd + integer(SHR_KIND_IN) ,intent(in) :: secIN ! base seconds + integer(SHR_KIND_IN) ,intent(out) :: dateOUT ! new date, yyyymmdd + integer(SHR_KIND_IN) ,intent(out) :: secOUT ! new seconds + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + !--- local --- + type(ESMF_time) :: timeIn, timeOut + type(ESMF_timeInterval) :: dt + integer(SHR_KIND_IN) :: year,month,day + character(len=shr_cal_calMaxLen) :: lcalendar + type(ESMF_CALKIND_FLAG) :: calkind + + !--- formats --- + character(*),parameter :: subName = "(shr_cal_advDateInt)" + character(*),parameter :: F00 = "('(shr_cal_advDateInt) ',a,i5)" + character(*),parameter :: F02 = "('(shr_cal_advDateInt) ',a,i8.8,f10.3)" + +!------------------------------------------------------------------------------- +! NOTE: +!------------------------------------------------------------------------------- + lcalendar = shr_cal_calendarName(calendar) + calkind = ESMF_CALKIND_NOLEAP + if (trim(lcalendar) == trim(shr_cal_gregorian)) then + calkind = ESMF_CALKIND_GREGORIAN + endif + + call shr_cal_date2ymd(dateIn,year,month,day) + call ESMF_TimeSet(timeIN,yy=year,mm=month,dd=day,s=secIn,calkindflag=calkind) + + !--- calculate delta-time in seconds --- + if (trim(units) == 'days' ) then + call ESMF_TimeIntervalSet(dt,d=delta) + elseif (trim(units) == 'hours' ) then + call ESMF_TimeIntervalSet(dt,h=delta) + elseif (trim(units) == 'minutes') then + call ESMF_TimeIntervalSet(dt,m=delta) + elseif (trim(units) == 'seconds') then + call ESMF_TimeIntervalSet(dt,s=delta) + else + call shr_sys_abort(trim(subname)//' ERROR: unrecognized time units '//trim(units)) + endif + + timeOut = timeIn + dt + + call ESMF_TimeGet(timeOut,yy=year,mm=month,dd=day,s=secOut) + call shr_cal_ymd2date(year,month,day,dateOut) + + if (debug>0) then + if (s_loglev > 0) write(s_logunit,*) subName," units,delta,calendar=",trim(units),delta,' ',trim(calendar) + if (s_loglev > 0) write(s_logunit,F02) "dateIN ,secIN =",dateIN ,secIN + if (s_loglev > 0) write(s_logunit,F02) "dateOUT,secOUT=",dateOUT,secOUT + end if + +end subroutine shr_cal_advDateInt + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_validDate - determines if coded-date is a valid date +! +! !DESCRIPTION: +! Determines if the given coded-date is a valid date. +! +! !REVISION HISTORY: +! 2001-dec-28 - B. Kauffman - initial version, taken from cpl5 +! +! !INTERFACE: ----------------------------------------------------------------- + +logical function shr_cal_validDate(date,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: date ! coded (yyyymmdd) calendar date + character(len=*) ,intent(in ) :: calendar ! calendar + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: year,month,day + integer(SHR_KIND_IN) :: tdate + character(*),parameter :: subName = "(shr_cal_validDate)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_cal_date2ymd(date,year,month,day) + shr_cal_validDate = shr_cal_validYMD(year,month,day,calendar) + +end function shr_cal_validDate + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_validYMD - determines if year, month, day is a valid date +! +! !DESCRIPTION: +! Determines if the given year, month, and day indicate a valid date. +! +! !REVISION HISTORY: +! 2001-dec-28 - B. Kauffman - initial version, taken from cpl5 +! +! !INTERFACE: ----------------------------------------------------------------- + +logical function shr_cal_validYMD(year,month,day,calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: year,month,day ! year,month,day + character(len=*) ,intent(in ) :: calendar ! calendar + +!EOP + + !--- local --- + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + shr_cal_validYMD = .true. + if (year < -999) shr_cal_validYMD = .false. + if (year > 9999) shr_cal_validYMD = .false. + if (month < 1) shr_cal_validYMD = .false. + if (month > 12) shr_cal_validYMD = .false. + if (day < 1) shr_cal_validYMD = .false. + if (day > shr_cal_numDaysInMonth(year,month,calendar)) & + shr_cal_validYMD = .false. + +end function shr_cal_validYMD + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_validHMS - determines if hour, min, sec is valid +! +! !DESCRIPTION: +! Determines if the given hour, min, sec is valid +! +! !REVISION HISTORY: +! 2005-May-15 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +logical function shr_cal_validHMS(hr,min,sec) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in ) :: hr, min, sec ! hour, minute, second + +!EOP + + !--- local --- + character(*),parameter :: subName = "(shr_cal_validHMS)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + shr_cal_validHMS = .true. + if (hr < 0) shr_cal_validHMS = .false. + if (hr > 23) shr_cal_validHMS = .false. + if (min < 0) shr_cal_validHMS = .false. + if (min > 59) shr_cal_validHMS = .false. + if (sec < 0) shr_cal_validHMS = .false. + if (sec > 60) shr_cal_validHMS = .false. + +end function shr_cal_validHMS + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_setDebug -- Set local shr_cal debug level +! +! !DESCRIPTION: +! Set local shr\_cal debug level, 0 = production +! \newline +! General Usage: call shr\_cal\_setDebug(2) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_cal_setDebug(level) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(in) :: level + +!EOP + + !--- formats --- + character(*),parameter :: subName = "(shr_cal_setDebug) " + character(*),parameter :: F00 = "('(shr_cal_setDebug) ',a) " + character(*),parameter :: F01 = "('(shr_cal_setDebug) ',a,i4) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + debug = level + if (s_loglev > 0) write(s_logunit,F01) "debug level reset to ",level + +end subroutine shr_cal_setDebug + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_cal_getDebug -- get shr_cal internal debug level +! +! !DESCRIPTION: +! Get shr_cal internal debug level, 0 = production +! \newline +! General Usage: call shr\_cal\_getDebug(level) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_cal_getDebug(level) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(out) :: level + +!EOP + + !--- formats --- + character(*),parameter :: subName = "(shr_cal_getDebug) " + character(*),parameter :: F00 = "('(shr_cal_getDebug) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + level = debug + +end subroutine shr_cal_getDebug + +!=============================================================================== +!=============================================================================== + +end module shr_cal_mod diff --git a/share/csm_share/shr/shr_const_mod.F90 b/share/csm_share/shr/shr_const_mod.F90 new file mode 100644 index 000000000000..9aa26ab2dc27 --- /dev/null +++ b/share/csm_share/shr/shr_const_mod.F90 @@ -0,0 +1,83 @@ +!=============================================================================== +! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ +!=============================================================================== + +MODULE shr_const_mod + + use shr_kind_mod + + integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8 ! rename for local readability only + + !---------------------------------------------------------------------------- + ! physical constants (all data public) + !---------------------------------------------------------------------------- + public + + real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8 ! pi + real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8 ! sec in calendar day ~ sec + real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8 ! sec in siderial day ~ sec + real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec + real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8 ! radius of earth ~ m + real(R8),parameter :: SHR_CONST_G = 9.80616_R8 ! acceleration of gravity ~ m/s^2 + + real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8 ! Stefan-Boltzmann constant ~ W/m^2/K^4 + real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8 ! Boltzmann's constant ~ J/K/molecule + real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8 ! Avogadro's number ~ molecules/kmole + real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ ! Universal gas constant ~ J/K/kmole + real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8 ! molecular weight dry air ~ kg/kmole + real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8 ! molecular weight water vapor + real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR ! Dry air gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV ! Water vapor gas constant ~ J/K/kg + real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0 + real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8 ! Von Karman constant + real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8 ! standard pressure ~ pascals + real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8 ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard) + + real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8 ! triple point of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8 ! freezing T of fresh water ~ K + real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water ~ K + real(R8),parameter :: SHR_CONST_ZSRFLYR = 3.0_R8 ! ocn surf layer depth for diurnal SST cal ~ m + + real(R8),parameter :: SHR_CONST_RHODAIR = & ! density of dry air at STP ~ kg/m^3 + SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ) + real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8 ! density of fresh water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8 ! density of sea water ~ kg/m^3 + real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8 ! density of ice ~ kg/m^3 + real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8 ! specific heat of dry air ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8 ! specific heat of water vap ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0 + real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8 ! specific heat of fresh h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8 ! specific heat of sea h2o ~ J/kg/K + real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8 ! specific heat of fresh ice ~ J/kg/K + real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8 ! latent heat of fusion ~ J/kg + real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8 ! latent heat of evaporation ~ J/kg + real(R8),parameter :: SHR_CONST_LATSUB = & ! latent heat of sublimation ~ J/kg + SHR_CONST_LATICE + SHR_CONST_LATVAP + real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8 ! ocn ref salinity (psu) + real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8 ! ice ref salinity (psu) + + real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8 ! special missing value + real(R8),parameter :: SHR_CONST_SPVAL_TOLMIN = 0.99_R8 * SHR_CONST_SPVAL ! min spval tolerance + real(R8),parameter :: SHR_CONST_SPVAL_TOLMAX = 1.01_R8 * SHR_CONST_SPVAL ! max spval tolerance + +contains + +!----------------------------------------------------------------------------- + + logical function shr_const_isspval(rval) + + real(r8), intent(in) :: rval + + if (rval > SHR_CONST_SPVAL_TOLMIN .and. & + rval < SHR_CONST_SPVAL_TOLMAX) then + shr_const_isspval = .true. + else + shr_const_isspval = .false. + endif + + end function shr_const_isspval + +!----------------------------------------------------------------------------- + +END MODULE shr_const_mod diff --git a/share/csm_share/shr/shr_dmodel_mod.F90 b/share/csm_share/shr/shr_dmodel_mod.F90 new file mode 100644 index 000000000000..7eefbcd39c4b --- /dev/null +++ b/share/csm_share/shr/shr_dmodel_mod.F90 @@ -0,0 +1,1562 @@ +module shr_dmodel_mod + +! !USES: + + use shr_sys_mod + use shr_kind_mod, only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, & + CX=>SHR_KIND_CX, CXX=>SHR_KIND_CXX + use shr_log_mod, only: loglev => shr_log_Level + use shr_log_mod, only: logunit => shr_log_Unit + use shr_mpi_mod, only: shr_mpi_bcast + use mct_mod +! use esmf + use perf_mod + use pio + +! !PUBLIC TYPES: + implicit none + private ! except + +!-------------------------------------------------------------------------- +! Public interfaces +!-------------------------------------------------------------------------- + + public :: shr_dmodel_gsmapCreate + public :: shr_dmodel_readLBUB + public :: shr_dmodel_readgrid + public :: shr_dmodel_gGridCompare + public :: shr_dmodel_mapSet + public :: shr_dmodel_translateAV + public :: shr_dmodel_translateAV_list + public :: shr_dmodel_translate_list + public :: shr_dmodel_rearrGGrid + + interface shr_dmodel_mapSet; module procedure & + shr_dmodel_mapSet_global +! shr_dmodel_mapSet_dest + end interface + + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYabs = 1 ! X,Y relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYrel = 2 ! X,Y absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaAbs = 3 ! area relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaRel = 4 ! area absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskIdent = 5 ! masks are identical + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskZeros = 6 ! masks have same zeros + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskSubset = 7 ! mask is subset of other + + ! masked methods + + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYabsMask = 101 ! X,Y relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareXYrelMask = 102 ! X,Y absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaAbsMask = 103 ! area relative error + integer(IN),parameter,public :: shr_dmodel_gGridCompareAreaRelMask = 104 ! area absolute error + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskIdentMask = 105 ! masks are identical + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskZerosMask = 106 ! masks have same zeros + integer(IN),parameter,public :: shr_dmodel_gGridCompareMaskSubsetMask = 107 ! mask is subset of other + + integer(IN),parameter,public :: iotype_std_netcdf = -99 ! non pio option + +!-------------------------------------------------------------------------- +! Private data +!-------------------------------------------------------------------------- + + !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CONTAINS +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +subroutine shr_dmodel_gsmapCreate(gsmap,gsize,compid,mpicom,decomp) + + implicit none + + type(mct_gsMap), intent(inout) :: gsmap + integer(IN) , intent(in) :: gsize + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in) :: decomp + + ! local + + integer(IN) :: n,npes,ierr + integer(IN), pointer :: start(:) ! for gsmap initialization + integer(IN), pointer :: length(:) ! for gsmap initialization + integer(IN), pointer :: pe_loc(:) ! for gsmap initialization + character(*), parameter :: subname = '(shr_dmodel_gsmapCreate) ' + character(*), parameter :: F00 = "('(shr_dmodel_gsmapCreate) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_gsmapCreate) ',a,5i8)" + + ! --------------------------------------------- + + if (gsize > 0) then + call mpi_comm_size(mpicom,npes,ierr) + allocate(start(npes),length(npes),pe_loc(npes)) + + start = 0 + length = 0 + do n = 1,npes + if (trim(decomp) == '1d') then + length(n) = gsize/npes + if (n <= mod(gsize,npes)) length(n) = length(n) + 1 + elseif (trim(decomp) == 'root') then + length = 0 + length(1) = gsize + else + write(logunit,F00) ' ERROR: decomp not allowed, ',trim(decomp) + call shr_sys_abort(subname//' ERROR decomp') + endif + if (n == 1) then + start(n) = 1 + else + start(n) = start(n-1) + length(n-1) + endif + pe_loc(n) = n-1 + enddo + call mct_gsMap_init( gsMap, COMPID, npes, gsize, start, length, pe_loc) + deallocate(start,length,pe_loc) + endif + +end subroutine shr_dmodel_gsmapCreate +!=============================================================================== + +subroutine shr_dmodel_readgrid( gGrid, gsMap, nxgo, nygo, filename, compid, mpicom, & + decomp, lonname, latname, maskname, areaname, fracname, readfrac, & + scmmode, scmlon, scmlat) + + use seq_flds_mod, only : seq_flds_dom_coord, seq_flds_dom_other + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_string_mod, only : shr_string_lastindex + use shr_ncread_mod, only : shr_ncread_domain, shr_ncread_vardimsizes, & + shr_ncread_varexists, shr_ncread_vardimnum + implicit none + + !----- arguments ----- + type(mct_gGrid), intent(inout) :: gGrid + type(mct_gsMap), intent(inout) :: gsMap + integer(IN) , intent(out) :: nxgo + integer(IN) , intent(out) :: nygo + character(len=*),intent(in) :: filename + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),optional,intent(in) :: decomp ! decomp strategy for gsmap + character(len=*),optional,intent(in) :: lonname ! name of lon variable in file + character(len=*),optional,intent(in) :: latname ! name of lat variable in file + character(len=*),optional,intent(in) :: maskname ! name of mask variable in file + character(len=*),optional,intent(in) :: areaname ! name of area variable in file + character(len=*),optional,intent(in) :: fracname ! name of frac variable in file + logical ,optional,intent(in) :: readfrac ! T <=> also read frac in file + logical ,optional,intent(in) :: scmmode ! single column mode + real(R8) ,optional,intent(in) :: scmlon ! single column lon + real(R8) ,optional,intent(in) :: scmlat ! single column lat + + !----- local ----- + integer(IN) :: n,k,j,i ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: my_task, master_task + integer(IN) :: ierr ! error code + logical :: fileexists ! + integer(IN) :: rCode ! return code + character(CL) :: remoteFn ! input file name (possibly at an archival location) + character(CL) :: localFn ! file name to be opened (possibly a local copy) + character(CS) :: prefix ! file prefix + character(CS) :: ldecomp ! decomp strategy + character(CS) :: llatname ! name of lat variable + character(CS) :: llonname ! name of lon variable + character(CS) :: lmaskname ! name of mask variable + character(CS) :: lareaname ! name of area variable + character(CS) :: lfracname ! name of area variable + logical :: lreadfrac ! read fraction + logical :: maskexists ! is mask on dataset + integer(IN) :: nxg,nyg ! size of input fields + integer(IN) :: ndims ! number of dims + integer(IN) :: nlon,nlat,narea,nmask,nfrac + logical :: lscmmode ! local scm mode + real(R8) :: dist,mind ! scmmode point search + integer(IN) :: ni,nj ! scmmode point search + real(R8) :: lscmlon ! local copy of scmlon + + real (R8),allocatable :: lon(:,:) ! temp array for domain lon info + real (R8),allocatable :: lat(:,:) ! temp array for domain lat info + integer(IN),allocatable :: mask(:,:) ! temp array for domain mask info + real (R8),allocatable :: area(:,:) ! temp array for domain area info + real (R8),allocatable :: frac(:,:) ! temp array for domain frac info + + integer(IN), pointer :: idata(:) ! temporary + type(mct_ggrid) :: gGridRoot ! global mct ggrid + + character(*), parameter :: subname = '(shr_dmodel_readgrid) ' + character(*), parameter :: F00 = "('(shr_dmodel_readgrid) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readgrid) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Read MCT ggrid and set gsmap +!---------------------------------------------------------------------------- +! Notes: +! o as per shr_file_get(), the file name format is expected to be +! remoteFn = [location:][directory path]localFn +! eg. "foobar.nc" "/home/user/foobar.nc" "mss:/USER/fobar.nc" +! o assumes a very specific netCDF domain file format wrt var names, etc. +! +! TO DO: have the calling routine select/input the domain's file name +!---------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + lscmmode = .false. + if (present(scmmode)) then + lscmmode = scmmode + if (lscmmode) then + if (.not.present(scmlon) .or. .not.present(scmlat)) then + write(logunit,*) subname,' ERROR: scmmode must supply scmlon and scmlat' + call shr_sys_abort(subname//' ERROR: scmmode1 lon lat') + endif + if (my_task > 0) then + write(logunit,*) subname,' ERROR: scmmode must be run on one pe' + call shr_sys_abort(subname//' ERROR: scmmode2 tasks') + endif + endif + endif + + if (my_task == master_task) then + if ( shr_file_queryPrefix(fileName,prefix=prefix) /= shr_file_noPrefix ) then + n = max(len_trim(prefix),shr_string_lastIndex(fileName,"/")) + remoteFn = fileName + localFn = fileName(n+1: len_trim(fileName) ) + call shr_file_get(rCode,localFn,remoteFn) + else + remoteFn = "undefined" ! this isn't needed + localFn = fileName ! file to open + end if + inquire(file=trim(localFn),exist=fileExists) + if (.not. fileExists) then + write(logunit,F00) "ERROR: file does not exist: ", trim(localFn) + call shr_sys_abort(subName//"ERROR: file does not exist: "//trim(localFn)) + end if + endif + + lreadfrac = .false. + ldecomp = "1d" + llonname = "xc" ! default values / standard data model domain file format + llatname = "yc" + lmaskname = "mask" + lareaname = "area" + lfracname = "frac" + if (present( decomp)) ldecomp = decomp + if (present(readfrac)) lreadfrac = readfrac + if (present( lonname)) llonname = lonname + if (present( latname)) llatname = latname + if (present(maskname)) lmaskname = maskname + if (present(areaname)) lareaname = areaname + if (present(fracname)) lfracname = fracname + + ! Initialize mct domain type + ! lat/lon in degrees, area in radians^2, mask is 1 (ocean), 0 (non-ocean) + + if (my_task == master_task) then + if (shr_ncread_varexists(localFn,lmaskname)) then + maskexists = .true. + call shr_ncread_varDimSizes(localFn,lmaskname,nxg,nyg) + else + maskexists = .false. + call shr_ncread_varDimNum(localFn,llonName,ndims) + if (ndims == 1) then + call shr_ncread_varDimSizes(localFn,llonName,nxg) + call shr_ncread_varDimSizes(localFn,llatName,nyg) + else + call shr_ncread_varDimSizes(localFn,llonName,nxg,nyg) + endif + endif + endif + call shr_mpi_bcast(nxg,mpicom) + call shr_mpi_bcast(nyg,mpicom) + if (lscmmode) then + nxgo = 1 + nygo = 1 + gsize = 1 + else + nxgo = nxg + nygo = nyg + gsize = nxg*nyg + if (gsize < 1) return + endif + + call shr_dmodel_gsmapCreate(gsMap,gsize,compid,mpicom,trim(ldecomp)) + lsize = mct_gsMap_lsize(gsMap, mpicom) + call mct_gGrid_init( GGrid=gGrid, CoordChars=trim(seq_flds_dom_coord), & + OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + + ! Determine global gridpoint number attribute, GlobGridNum, automatically in ggrid + + call mct_gsMap_orderedPoints(gsMap, my_task, idata) + call mct_gGrid_importIAttr(gGrid,'GlobGridNum',idata,lsize) + deallocate(idata) + + ! Initialize attribute vector with special value + + gGrid%data%rAttr = -9999.0_R8 + + ! Load file data into domG then scatter to ggrid + + if (my_task == master_task) then + + allocate(lon(nxg,nyg)) + allocate(lat(nxg,nyg)) + allocate(area(nxg,nyg)) + allocate(mask(nxg,nyg)) + allocate(frac(nxg,nyg)) + + if (.not.maskexists) then + call shr_ncread_domain(localFn,llonName,lon,llatName,lat) + mask = 1 + frac = 1.0_R8 + area = 1.0e36_R8 + else + if (lreadfrac) then + call shr_ncread_domain(localFn,llonName,lon,llatName,lat, & + lmaskName,mask,lareaName,area,lfracName,frac) + else ! assume frac = 1.0 + call shr_ncread_domain(localFn,llonName,lon,llatName,lat, & + lmaskName,mask,lareaName,area) + where (mask == 0) + frac = 0.0_R8 + elsewhere + frac = 1.0_R8 + end where + endif + endif + + call mct_gGrid_init(gGridRoot,gGrid,gsize) + +! initialize gGridRoot to avoid errors when using strict compiler checks + gGridRoot%data%rAttr = -9999.0_R8 + + nlon = mct_aVect_indexRA(gGridRoot%data,'lon') + nlat = mct_aVect_indexRA(gGridRoot%data,'lat') + narea = mct_aVect_indexRA(gGridRoot%data,'area') + nmask = mct_aVect_indexRA(gGridRoot%data,'mask') + nfrac = mct_aVect_indexRA(gGridRoot%data,'frac') + + if (lscmmode) then + !--- assumes regular 2d grid for compatability with shr_scam_getCloseLatLon --- + !--- want lon values between 0 and 360, assume 1440 is enough --- + lscmlon = mod(scmlon+1440.0_r8,360.0_r8) + lon = mod(lon +1440.0_r8,360.0_r8) + + !--- start with wraparound --- + ni = 1 + mind = abs(lscmlon - (lon(1,1)+360.0_r8)) + do i=1,nxg + dist = abs(lscmlon - lon(i,1)) + if (dist < mind) then + mind = dist + ni = i + endif + enddo + + nj = -1 + mind = 1.0e20 + do j=1,nyg + dist = abs(scmlat - lat(1,j)) + if (dist < mind) then + mind = dist + nj = j + endif + enddo + + n = 1 + i = ni + j = nj + gGridRoot%data%rAttr(nlat ,n) = lat(i,j) + gGridRoot%data%rAttr(nlon ,n) = lon(i,j) + gGridRoot%data%rAttr(narea,n) = area(i,j) + gGridRoot%data%rAttr(nmask,n) = real(mask(i,j),R8) + gGridRoot%data%rAttr(nfrac,n) = frac(i,j) + else + n=0 + do j=1,nyg + do i=1,nxg + n=n+1 + gGridRoot%data%rAttr(nlat ,n) = lat(i,j) + gGridRoot%data%rAttr(nlon ,n) = lon(i,j) + gGridRoot%data%rAttr(narea,n) = area(i,j) + gGridRoot%data%rAttr(nmask,n) = real(mask(i,j),R8) + gGridRoot%data%rAttr(nfrac,n) = frac(i,j) + enddo + enddo + endif + deallocate(lon) + deallocate(lat) + deallocate(area) + deallocate(mask) + deallocate(frac) + endif + + call mct_gGrid_scatter(gGridRoot, gGrid, gsMap, master_task, mpicom) + if (my_task == master_task) call mct_gGrid_clean(gGridRoot) + +end subroutine shr_dmodel_readgrid + +!=============================================================================== + +subroutine shr_dmodel_readLBUB(stream,pio_subsystem,pio_iotype,pio_iodesc,mDate,mSec,mpicom,gsMap, & + avLB,mDateLB,mSecLB,avUB,mDateUB,mSecUB,newData,rmOldFile,istr) + + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_const_mod, only : shr_const_cDay + use shr_stream_mod + implicit none + + !----- arguments ----- + type(shr_stream_streamType),intent(inout) :: stream + type(iosystem_desc_t) ,intent(inout), target :: pio_subsystem + integer(IN) ,intent(in) :: pio_iotype + type(io_desc_t) ,intent(inout) :: pio_iodesc + integer(IN) ,intent(in) :: mDate ,mSec + integer(IN) ,intent(in) :: mpicom + type(mct_gsMap) ,intent(in) :: gsMap + type(mct_aVect) ,intent(inout) :: avLB + integer(IN) ,intent(inout) :: mDateLB,mSecLB + type(mct_aVect) ,intent(inout) :: avUB + integer(IN) ,intent(inout) :: mDateUB,mSecUB + logical ,intent(out) :: newData + logical,optional ,intent(in) :: rmOldFile + character(len=*),optional ,intent(in) :: istr + + !----- local ----- + integer(IN) :: n,k,j,i ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: my_task, master_task + integer(IN) :: ierr ! error code + integer(IN) :: rCode ! return code + logical :: localCopy,fileexists + integer(IN) :: ivals(6) ! bcast buffer + + integer(IN) :: oDateLB,oSecLB,dDateLB,oDateUB,oSecUB,dDateUB + real(R8) :: rDateM,rDateLB,rDateUB ! model,LB,UB dates with fractional days + integer(IN) :: n_lb, n_ub + character(CL) :: fn_lb,fn_ub,fn_next,fn_prev + character(CL) :: path + character(len=32) :: lstr + + real(R8) :: spd + + character(*), parameter :: subname = '(shr_dmodel_readLBUB) ' + character(*), parameter :: F00 = "('(shr_dmodel_readLBUB) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readLBUB) ',a,5i8)" + character(*), parameter :: F02 = "('(shr_dmodel_readLBUB) ',3a,i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Read LB and UB stream data +!---------------------------------------------------------------------------- + + lstr = 'shr_dmodel_readLBUB' + if (present(istr)) then + lstr = trim(istr) + endif + + call t_startf(trim(lstr)//'_setup') + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + spd = shr_const_cday + + newData = .false. + n_lb = -1 + n_ub = -1 + fn_lb = 'undefinedlb' + fn_ub = 'undefinedub' + + oDateLB = mDateLB + oSecLB = mSecLB + oDateUB = mDateUB + oSecUB = mSecUB + + rDateM = real(mDate ,R8) + real(mSec ,R8)/spd + rDateLB = real(mDateLB,R8) + real(mSecLB,R8)/spd + rDateUB = real(mDateUB,R8) + real(mSecUB,R8)/spd + call t_stopf(trim(lstr)//'_setup') + + if (rDateM < rDateLB .or. rDateM > rDateUB) then + call t_startf(trim(lstr)//'_fbound') + if (my_task == master_task) then +! call shr_stream_findBounds(stream,mDate,mSec, & +! mDateLB,dDateLB,mSecLB,n_lb,fn_lb, & +! mDateUB,dDateUB,mSecUB,n_ub,fn_ub ) + call shr_stream_findBounds(stream,mDate,mSec, & + ivals(1),dDateLB,ivals(2),ivals(5),fn_lb, & + ivals(3),dDateUB,ivals(4),ivals(6),fn_ub ) + call shr_stream_getFilePath(stream,path) + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + endif + call t_stopf(trim(lstr)//'_fbound') + call t_startf(trim(lstr)//'_bcast') + +! --- change 4 bcasts to a single bcast and copy for performance --- +! call shr_mpi_bcast(mDateLB,mpicom) +! call shr_mpi_bcast(mSecLB,mpicom) +! call shr_mpi_bcast(mDateUB,mpicom) +! call shr_mpi_bcast(mSecUB,mpicom) + call shr_mpi_bcast(stream%calendar,mpicom) + call shr_mpi_bcast(ivals,mpicom) + mDateLB = ivals(1) + mSecLB = ivals(2) + mDateUB = ivals(3) + mSecUB = ivals(4) + n_lb = ivals(5) + n_ub = ivals(6) + call t_stopf(trim(lstr)//'_bcast') + endif + + if (mDateLB /= oDateLB .or. mSecLB /= oSecLB) then + newdata = .true. + if (mDateLB == oDateUB .and. mSecLB == oSecUB) then + call t_startf(trim(lstr)//'_LB_copy') + avLB%rAttr(:,:) = avUB%rAttr(:,:) + call t_stopf(trim(lstr)//'_LB_copy') + else + if (my_task == master_task) then + write(logunit,F02) 'reading file: ',trim(path),trim(fn_lb),n_lb + call shr_sys_flush(logunit) + endif + call shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, avLB, mpicom, & + path, fn_lb, n_lb,istr=trim(lstr)//'_LB') + endif + endif + + if (mDateUB /= oDateUB .or. mSecUB /= oSecUB) then + newdata = .true. + if (my_task == master_task) then + write(logunit,F02) 'reading file: ',trim(path),trim(fn_ub),n_ub + call shr_sys_flush(logunit) + endif + call shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, avUB, mpicom, & + path, fn_ub, n_ub,istr=trim(lstr)//'_UB') + endif + + call t_startf(trim(lstr)//'_filemgt') + !--- determine previous & next data files in list of files --- + if (my_task == master_task .and. newdata) then + call shr_stream_getFilePath(stream,path) + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + if (localCopy) then + call shr_stream_getPrevFileName(stream,fn_lb,fn_prev,path) + call shr_stream_getNextFileName(stream,fn_ub,fn_next,path) + inquire(file=trim(fn_next),exist=fileExists) + if ( trim(fn_next) == "unknown" .or. fileExists) then + ! do nothing + else + call shr_file_get(rCode,fn_next,trim(path)//fn_next,async=.true.) + write(logunit,F00) "get next file: ",trim(fn_next) + call shr_sys_flush(logunit) + end if + + !--- remove the old file? (only if acquiring local copies) --- + if ( rmOldFile .and. & + fn_prev/=fn_lb .and. fn_prev/=fn_ub .and. fn_prev/=fn_next ) then + !--- previous file is not in use and is not next in list --- + inquire(file=trim(fn_prev),exist=fileExists) + if ( fileExists ) then + call shr_sys_system(" rm "//trim(fn_prev),rCode) + write(logunit,F00) "rm prev file: ",trim(fn_prev) + call shr_sys_flush(logunit) + end if + end if + endif + endif + call t_stopf(trim(lstr)//'_filemgt') + +end subroutine shr_dmodel_readLBUB + +!=============================================================================== +subroutine shr_dmodel_readstrm(stream, pio_subsystem, pio_iotype, pio_iodesc, gsMap, av, mpicom, & + path, fn, nt, istr) + + use shr_file_mod, only : shr_file_noprefix, shr_file_queryprefix, shr_file_get + use shr_stream_mod + use shr_ncread_mod + implicit none + + !----- arguments ----- + type(shr_stream_streamType),intent(inout) :: stream + type(iosystem_desc_t),intent(inout), target :: pio_subsystem + integer(IN) ,intent(in) :: pio_iotype + type(io_desc_t) ,intent(inout) :: pio_iodesc + type(mct_gsMap) ,intent(in) :: gsMap + type(mct_aVect) ,intent(inout) :: av + integer(IN) ,intent(in) :: mpicom + character(len=*),intent(in) :: path + character(len=*),intent(in) :: fn + integer(IN) ,intent(in) :: nt + character(len=*),optional ,intent(in) :: istr + + !----- local ----- + integer(IN) :: my_task + integer(IN) :: master_task + integer(IN) :: ierr + logical :: localCopy,fileexists + type(mct_avect) :: avG + integer(IN) :: gsize,nx,ny + integer(IN) :: k + integer(IN) :: fid + integer(IN) :: rCode ! return code + real(R8),allocatable :: data(:,:) + character(CL) :: fileName + character(CL) :: sfldName + type(mct_avect) :: avtmp + character(len=32) :: lstr + + integer(in) :: ndims + integer(in),pointer :: dimid(:) + type(file_desc_t) :: pioid + type(var_desc_t) :: varid + integer(kind=pio_offset_kind) :: frame + + character(*), parameter :: subname = '(shr_dmodel_readstrm) ' + character(*), parameter :: F00 = "('(shr_dmodel_readstrm) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_readstrm) ',a,5i8)" + +!------------------------------------------------------------------------------- + + lstr = 'shr_dmodel_readstrm' + if (present(istr)) then + lstr = trim(istr) + endif + + call t_barrierf(trim(lstr)//'_BARRIER',mpicom) + call t_startf(trim(lstr)//'_setup') + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + gsize = mct_gsmap_gsize(gsMap) + + if (my_task == master_task) then + localCopy = (shr_file_queryPrefix(path) /= shr_file_noPrefix ) + if (localCopy) then + call shr_file_get(rCode,fn,trim(path)//fn) + fileName = fn + else ! DON'T acquire a local copy of the data file + fileName = trim(path)//fn + end if + inquire(file=trim(fileName),exist=fileExists) + if (.not. fileExists) then + write(logunit,F00) "ERROR: file does not exist: ", trim(fileName) + call shr_sys_abort(subName//"ERROR: file does not exist: "//trim(fileName)) + end if + endif + + if (my_task == master_task) then + call shr_stream_getFileFieldName(stream,1,sfldName) + endif + + call t_stopf(trim(lstr)//'_setup') + + if (pio_iotype == iotype_std_netcdf) then + + call t_startf(trim(lstr)//'_readcdf') + if (my_task == master_task) then + call shr_ncread_varDimSizes(trim(fileName),trim(sfldName),nx,ny) + if (gsize /= nx*ny) then + write(logunit,F01) "ERROR in data sizes ",nx,ny,gsize + call shr_sys_abort(subname//"ERROR in data sizes") + endif + call mct_aVect_init(avG,av,gsize) + allocate(data(nx,ny)) + call shr_ncread_open(trim(fileName),fid,rCode) + do k = 1,mct_aVect_nRAttr(av) + call shr_stream_getFileFieldName(stream,k,sfldName) + call shr_ncread_tField(fileName,nt,sfldName,data,fidi=fid,rc=rCode) + avG%rAttr(k,:) = reshape(data, (/gsize/)) + enddo + call shr_ncread_close(fid,rCode) + deallocate(data) + endif + call t_stopf(trim(lstr)//'_readcdf') + call t_barrierf(trim(lstr)//'_scatter'//'_BARRIER',mpicom) + call t_startf(trim(lstr)//'_scatter') + call mct_aVect_scatter(avG,avtmp,gsMap,master_task,mpicom) + call mct_aVect_copy(avtmp,av) + if (my_task == master_task) call mct_aVect_clean(avG) + call mct_aVect_clean(avtmp) + call t_stopf(trim(lstr)//'_scatter') + + else + + call t_startf(trim(lstr)//'_readpio') + call shr_mpi_bcast(sfldName,mpicom,'sfldName') + call shr_mpi_bcast(filename,mpicom,'filename') + rcode = pio_openfile(pio_subsystem, pioid, pio_iotype, trim(filename), pio_nowrite) + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + + rcode = pio_inq_varid(pioid,trim(sfldName),varid) + rcode = pio_inq_varndims(pioid, varid, ndims) + allocate(dimid(ndims)) + rcode = pio_inq_vardimid(pioid, varid, dimid(1:ndims)) + rcode = pio_inq_dimlen(pioid, dimid(1), nx) + rcode = pio_inq_dimlen(pioid, dimid(2), ny) + deallocate(dimid) + if (gsize /= nx*ny) then + write(logunit,F01) "ERROR in data sizes ",nx,ny,gsize + call shr_sys_abort(subname//"ERROR in data sizes") + endif + + do k = 1,mct_aVect_nRAttr(av) + if (my_task == master_task) then + call shr_stream_getFileFieldName(stream,k,sfldName) + endif + call shr_mpi_bcast(sfldName,mpicom,'sfldName') + rcode = pio_inq_varid(pioid,trim(sfldName),varid) + frame = nt + call pio_setframe(pioid,varid,frame) + call pio_read_darray(pioid,varid,pio_iodesc,av%rattr(k,:),rcode) + enddo + + call pio_closefile(pioid) + call t_stopf(trim(lstr)//'_readpio') + + endif + +end subroutine shr_dmodel_readstrm +!=============================================================================== +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_dmodel_gGridCompare -- returns TRUE if two domains are the same. +! +! !DESCRIPTION: +! Returns TRUE if two domains are the the same (within tolerance). +! +! !REVISION HISTORY: +! 2005-May-03 - B. Kauffman - added mulitiple methods +! 2005-May-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_dmodel_gGridCompare(ggrid1,gsmap1,ggrid2,gsmap2,method,mpicom,eps) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_gGrid) ,intent(in) :: ggrid1 ! 1st ggrid + type(mct_gsmap) ,intent(in) :: gsmap1 ! 1st gsmap + type(mct_gGrid) ,intent(in) :: ggrid2 ! 2nd ggrid + type(mct_gsmap) ,intent(in) :: gsmap2 ! 2nd gsmap + integer(IN) ,intent(in) :: method ! selects what to compare + integer(IN) ,intent(in) :: mpicom ! mpicom + real(R8) ,optional,intent(in) :: eps ! epsilon compare value + +!EOP + + !--- local --- + real(R8) :: leps ! local epsilon + integer(IN) :: n ! counters + integer(IN) :: my_task,master_task + integer(IN) :: gsize + integer(IN) :: ierr + integer(IN) :: nlon1, nlon2, nlat1, nlat2, nmask1, nmask2 ! av field indices + logical :: compare ! local compare logical + real(R8) :: lon1,lon2 ! longitudes to compare + real(R8) :: lat1,lat2 ! latitudes to compare + real(R8) :: msk1,msk2 ! masks to compare + integer(IN) :: nx,ni1,ni2 ! i grid size, i offset for 1 vs 2 and 2 vs 1 + integer(IN) :: n1,n2,i,j ! local indices + type(mct_aVect) :: avG1 ! global av + type(mct_aVect) :: avG2 ! global av + integer(IN) :: lmethod ! local method + logical :: maskmethod, maskpoint ! masking on method + + !--- formats --- + character(*),parameter :: subName = '(shr_dmodel_gGridCompare) ' + character(*),parameter :: F01 = "('(shr_dmodel_gGridCompare) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + leps = 1.0e-6_R8 + if (present(eps)) leps = eps + + lmethod = mod(method,100) + if (method > 100) then + maskmethod=.true. + else + maskmethod=.false. + endif + + call mct_aVect_gather(gGrid1%data,avG1,gsmap1,master_task,mpicom) + call mct_aVect_gather(gGrid2%data,avG2,gsmap2,master_task,mpicom) + + if (my_task == master_task) then + + compare = .true. + gsize = mct_aVect_lsize(avG1) + if (gsize /= mct_aVect_lsize(avG2)) then + compare = .false. + endif + + if (.not. compare ) then + !--- already failed the comparison test, check no futher --- + else + nlon1 = mct_aVect_indexRA(avG1,'lon') + nlat1 = mct_aVect_indexRA(avG1,'lat') + nlon2 = mct_aVect_indexRA(avG2,'lon') + nlat2 = mct_aVect_indexRA(avG2,'lat') + nmask1 = mct_aVect_indexRA(avG1,'mask') + nmask2 = mct_aVect_indexRA(avG2,'mask') + + ! To compare, want to be able to treat longitude wraparound generally. + ! So we need to compute i index offset and we need to compute the size of the nx dimension + ! First adjust the lon so it's in the range [0,360), add 1440 to lon to take into + ! accounts lons less than 1440. if any lon is less than -1440, abort. 1440 is arbitrary + ! Next, comute ni1 and ni2. These are the offsets of grid1 relative to grid2 and + ! grid2 relative to grid1. The sum of those offsets is nx. Use ni1 to offset grid2 + ! in comparison and compute new grid2 index from ni1 and nx. If ni1 is zero, then + ! there is no offset, don't need to compute ni2, and nx can be anything > 0. + + !--- compute offset of grid2 compared to pt 1 of grid 1 + lon1 = minval(avG1%rAttr(nlon1,:)) + lon2 = minval(avG2%rAttr(nlon2,:)) + if ((lon1 < -1440.0_R8) .or. (lon2 < -1440.0_R8)) then + write(logunit,*) subname,' ERROR: lon1 lon2 lt -1440 ',lon1,lon2 + call shr_sys_abort(subname//' ERROR: lon1 lon2 lt -1440') + endif + + lon1 = mod(avG1%rAttr(nlon1,1)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,1) + ni1 = -1 + do n = 1,gsize + lon2 = mod(avG2%rAttr(nlon2,n)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,n) + if ((ni1 < 0) .and. abs(lon1-lon2) <= leps .and. abs(lat1-lat2) <= leps) then + ni1 = n - 1 ! offset, compare to first gridcell in grid 1 + endif + enddo + + if (ni1 < 0) then ! no match for grid point 1, so fails without going further + compare = .false. + elseif (ni1 == 0) then ! no offset, set nx to anything > 0 + nx = 1 + else ! now compute ni2 + ! compute offset of grid1 compared to pt 1 of grid 2 + lon2 = mod(avG2%rAttr(nlon2,1)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,1) + ni2 = -1 + do n = 1,gsize + lon1 = mod(avG1%rAttr(nlon1,n)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,n) + if ((ni2 < 0) .and. abs(lon1-lon2) <= leps .and. abs(lat1-lat2) <= leps) then + ni2 = n - 1 ! offset, compare to first gridcell in grid 1 + endif + enddo + if (ni2 < 0) then + write(logunit,*) subname,' ERROR in ni2 ',ni1,ni2 + call shr_sys_abort(subname//' ERROR in ni2') + endif + nx = ni1 + ni2 + endif + + if (compare) then + do n = 1,gsize + j = ((n-1)/nx) + 1 + i = mod(n-1,nx) + 1 + n1 = (j-1)*nx + mod(n-1,nx) + 1 + n2 = (j-1)*nx + mod(n-1+ni1,nx) + 1 + if (n1 /= n) then ! sanity check, could be commented out + write(logunit,*) subname,' ERROR in n1 n2 ',n,i,j,n1,n2 + call shr_sys_abort(subname//' ERROR in n1 n2') + endif + lon1 = mod(avG1%rAttr(nlon1,n1)+1440.0_R8,360.0_R8) + lat1 = avG1%rAttr(nlat1,n1) + lon2 = mod(avG2%rAttr(nlon2,n2)+1440.0_R8,360.0_R8) + lat2 = avG2%rAttr(nlat2,n2) + msk1 = avG1%rAttr(nmask1,n1) + msk2 = avG2%rAttr(nmask2,n2) + + maskpoint = .true. + if (maskmethod .and. (msk1 == 0 .or. msk2 == 0)) then + maskpoint = .false. + endif + + if (maskpoint) then + if (lmethod == shr_dmodel_gGridCompareXYabs ) then + if (abs(lon1 - lon2) > leps) compare = .false. + if (abs(lat1 - lat2) > leps) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareXYrel ) then + if (rdiff(lon1,lon2) > leps) compare = .false. + if (rdiff(lat1,lat2) > leps) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskIdent ) then + if (msk1 /= msk2)compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskZeros ) then + if (msk1 == 0 .and. msk2 /= 0) compare = .false. + if (msk1 /= 0 .and. msk2 == 0) compare = .false. + else if (lmethod == shr_dmodel_gGridCompareMaskSubset ) then + if (msk1 /= 0 .and. msk2 == 0) compare = .false. + else + write(logunit,F01) "ERROR: compare method not recognized, method = ",method + call shr_sys_abort(subName//"ERROR: compare method not recognized") + endif ! lmethod + endif ! maskpoint + enddo ! gsize + endif ! compare + endif ! compare + endif ! master_task + + if (my_task == master_task) call mct_avect_clean(avG1) + if (my_task == master_task) call mct_avect_clean(avG2) + + call shr_mpi_bcast(compare,mpicom) + shr_dmodel_gGridCompare = compare + + return + +!------------------------------------------------------------------------------- +contains ! internal subprogram +!------------------------------------------------------------------------------- + + real(R8) function rdiff(v1,v2) ! internal function + !------------------------------------------ + real(R8),intent(in) :: v1,v2 ! two values to compare + real(R8),parameter :: c0 = 0.0_R8 ! zero + real(R8),parameter :: large_number = 1.0e20_R8 ! infinity + !------------------------------------------ + if (v1 == v2) then + rdiff = c0 + elseif (v1 == c0 .and. v2 /= c0) then + rdiff = large_number + elseif (v2 == c0 .and. v1 /= c0) then + rdiff = large_number + else +! rdiff = abs((v2-v1)/v1) ! old version, but rdiff(v1,v2) /= vdiff(v2,v1) + rdiff = abs(2.0_R8*(v2-v1)/(v1+v2)) + endif + !------------------------------------------ + end function rdiff + +end function shr_dmodel_gGridCompare + +!=============================================================================== + +subroutine shr_dmodel_mapSet_global(smatp,ggridS,gsmapS,nxgS,nygS,ggridD,gsmapD,nxgD,nygD, & + name,type,algo,mask,vect,compid,mpicom,strategy) + + use shr_map_mod + implicit none + + !----- arguments ----- + type(mct_sMatP), intent(inout) :: smatp + type(mct_gGrid), intent(in) :: ggridS + type(mct_gsmap), intent(in) :: gsmapS + integer(IN) , intent(in) :: nxgS + integer(IN) , intent(in) :: nygS + type(mct_gGrid), intent(in) :: ggridD + type(mct_gsmap), intent(in) :: gsmapD + integer(IN) , intent(in) :: nxgD + integer(IN) , intent(in) :: nygD + character(len=*),intent(in) :: name + character(len=*),intent(in) :: type + character(len=*),intent(in) :: algo + character(len=*),intent(in) :: mask + character(len=*),intent(in) :: vect + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in),optional :: strategy + + !----- local ----- + + integer(IN) :: n,i,j + integer(IN) :: lsizeS,gsizeS,lsizeD,gsizeD + integer(IN) :: nlon,nlat,nmsk + integer(IN) :: my_task,master_task,ierr + + real(R8) , pointer :: Xsrc(:,:) + real(R8) , pointer :: Ysrc(:,:) + integer(IN), pointer :: Msrc(:,:) + real(R8) , pointer :: Xdst(:,:) + real(R8) , pointer :: Ydst(:,:) + integer(IN), pointer :: Mdst(:,:) + type(shr_map_mapType) :: shrmap + type(mct_aVect) :: AVl + type(mct_aVect) :: AVg + + character(len=32) :: lstrategy + integer(IN) :: nsrc,ndst,nwts + integer(IN), pointer :: isrc(:) + integer(IN), pointer :: idst(:) + real(R8) , pointer :: wgts(:) + type(mct_sMat) :: sMat0 + + character(*), parameter :: subname = '(shr_dmodel_mapSet_global) ' + character(*), parameter :: F00 = "('(shr_dmodel_mapSet_global) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_mapSet_global) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Initialize sMatP from mct gGrid +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + !--- get sizes and allocate for SRC --- + + lsizeS = mct_aVect_lsize(ggridS%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeS) + call mct_avect_copy(ggridS%data,AVl,rList='lon:lat:mask') + call mct_avect_gather(AVl,AVg,gsmapS,master_task,mpicom) + + if (my_task == master_task) then + gsizeS = mct_aVect_lsize(AVg) + if (gsizeS /= nxgS*nygS) then + write(logunit,F01) ' ERROR: gsizeS ',gsizeS,nxgS,nygS + call shr_sys_abort(subname//' ERROR gsizeS') + endif + allocate(Xsrc(nxgS,nygS),Ysrc(nxgS,nygS),Msrc(nxgS,nygS)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Msrc = 1 + do j = 1,nygS + do i = 1,nxgS + n = n + 1 + Xsrc(i,j) = AVg%rAttr(nlon,n) + Ysrc(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Msrc(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- get sizes and allocate for DST --- + + lsizeD = mct_aVect_lsize(ggridD%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeD) + call mct_avect_copy(ggridD%data,AVl,rList='lon:lat:mask') + call mct_avect_gather(AVl,AVg,gsmapD,master_task,mpicom) + + if (my_task == master_task) then + gsizeD = mct_aVect_lsize(AVg) + if (gsizeD /= nxgD*nygD) then + write(logunit,F01) ' ERROR: gsizeD ',gsizeD,nxgD,nygD + call shr_sys_abort(subname//' ERROR gsizeD') + endif + allocate(Xdst(nxgD,nygD),Ydst(nxgD,nygD),Mdst(nxgD,nygD)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Mdst = 1 + do j = 1,nygD + do i = 1,nxgD + n = n + 1 + Xdst(i,j) = AVg%rAttr(nlon,n) + Ydst(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Mdst(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- set map --- + + if (my_task == master_task) then + call shr_map_mapSet(shrmap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst, & + trim(name),trim(type),trim(algo),trim(mask),trim(vect)) + deallocate(Xsrc,Ysrc,Msrc) + deallocate(Xdst,Ydst,Mdst) + endif + + !--- convert map to sMatP --- + + lstrategy = 'Xonly' + if (present(strategy)) then + lstrategy = trim(strategy) + endif + + if (my_task == master_task) then + call shr_map_get(shrmap,shr_map_fs_nsrc,nsrc) + call shr_map_get(shrmap,shr_map_fs_ndst,ndst) + call shr_map_get(shrmap,shr_map_fs_nwts,nwts) + allocate(isrc(nwts),idst(nwts),wgts(nwts)) + call shr_map_get(shrmap,isrc,idst,wgts) + call shr_map_clean(shrmap) + + call mct_sMat_init(sMat0,ndst,nsrc,nwts) + + call mct_sMat_ImpGColI (sMat0,isrc,nwts) + call mct_sMat_ImpGRowI (sMat0,idst,nwts) + call mct_sMat_ImpMatrix(sMat0,wgts,nwts) + deallocate(isrc,idst,wgts) + endif + + call mct_sMatP_Init(sMatP,sMat0,gsmapS,gsmapD,lstrategy,master_task,mpicom,compid) + + if (my_task == master_task) then + call mct_sMat_clean(sMat0) + endif + +end subroutine shr_dmodel_mapSet_global + +!=============================================================================== + +subroutine shr_dmodel_mapSet_dest(smatp,ggridS,gsmapS,nxgS,nygS,ggridD,gsmapD,nxgD,nygD, & + name,type,algo,mask,vect,compid,mpicom,strategy) + + use shr_map_mod + implicit none + + !----- arguments ----- + type(mct_sMatP), intent(inout) :: smatp + type(mct_gGrid), intent(in) :: ggridS + type(mct_gsmap), intent(in) :: gsmapS + integer(IN) , intent(in) :: nxgS + integer(IN) , intent(in) :: nygS + type(mct_gGrid), intent(in) :: ggridD + type(mct_gsmap), intent(in) :: gsmapD + integer(IN) , intent(in) :: nxgD + integer(IN) , intent(in) :: nygD + character(len=*),intent(in) :: name + character(len=*),intent(in) :: type + character(len=*),intent(in) :: algo + character(len=*),intent(in) :: mask + character(len=*),intent(in) :: vect + integer(IN) , intent(in) :: compid + integer(IN) , intent(in) :: mpicom + character(len=*),intent(in),optional :: strategy + + !----- local ----- + + integer(IN) :: n,i,j + integer(IN) :: lsizeS,gsizeS,lsizeD,gsizeD + integer(IN) :: nlon,nlat,nmsk + integer(IN) :: my_task,master_task,ierr + + real(R8) , pointer :: Xsrc(:,:) + real(R8) , pointer :: Ysrc(:,:) + integer(IN), pointer :: Msrc(:,:) + real(R8) , pointer :: Xdst(:) + real(R8) , pointer :: Ydst(:) + integer(IN), pointer :: Mdst(:) + type(shr_map_mapType) :: shrmap + type(mct_aVect) :: AVl + type(mct_aVect) :: AVg + + character(len=32) :: lstrategy + integer(IN) :: nsrc,ndst,nwts + integer(IN), pointer :: points(:) + integer(IN), pointer :: isrc(:) + integer(IN), pointer :: idst(:) + real(R8) , pointer :: wgts(:) + type(mct_sMat) :: sMat0 + + character(*), parameter :: subname = '(shr_dmodel_mapSet_dest) ' + character(*), parameter :: F00 = "('(shr_dmodel_mapSet_dest) ',8a)" + character(*), parameter :: F01 = "('(shr_dmodel_mapSet_dest) ',a,5i8)" + +!------------------------------------------------------------------------------- +! PURPOSE: Initialize sMatP from mct gGrid +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ierr) + master_task = 0 + + !--- get sizes and allocate for SRC --- + + lsizeS = mct_aVect_lsize(ggridS%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeS) + call mct_avect_copy(ggridS%data,AVl,rList='lon:lat:mask') + + call mct_avect_gather(AVl,AVg,gsmapS,master_task,mpicom) + + allocate(Xsrc(nxgS,nygS),Ysrc(nxgS,nygS),Msrc(nxgS,nygS)) + if (my_task == master_task) then + gsizeS = mct_aVect_lsize(AVg) + if (gsizeS /= nxgS*nygS) then + write(logunit,F01) ' ERROR: gsizeS ',gsizeS,nxgS,nygS + call shr_sys_abort(subname//' ERROR gsizeS') + endif + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Msrc = 1 + do j = 1,nygS + do i = 1,nxgS + n = n + 1 + Xsrc(i,j) = AVg%rAttr(nlon,n) + Ysrc(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Msrc(i,j) = 0 + enddo + enddo + endif + call shr_mpi_bcast(Xsrc,mpicom) + call shr_mpi_bcast(Ysrc,mpicom) + call shr_mpi_bcast(Msrc,mpicom) + + if (my_task == master_task) call mct_aVect_clean(AVg) + call mct_aVect_clean(AVl) + + !--- get sizes and allocate for DST --- + + lsizeD = mct_aVect_lsize(ggridD%data) + call mct_avect_init(AVl,rList='lon:lat:mask',lsize=lsizeD) + call mct_avect_copy(ggridD%data,AVl,rList='lon:lat:mask') + +#if (1 == 0) + call mct_avect_gather(AVl,AVg,gsmapD,master_task,mpicom) + + if (my_task == master_task) then + gsizeD = mct_aVect_lsize(AVg) + if (gsizeD /= nxgD*nygD) then + write(logunit,F01) ' ERROR: gsizeD ',gsizeD,nxgD,nygD + call shr_sys_abort(subname//' ERROR gsizeD') + endif + allocate(Xdst(nxgD,nygD),Ydst(nxgD,nygD),Mdst(nxgD,nygD)) + + nlon = mct_avect_indexRA(AVg,'lon') + nlat = mct_avect_indexRA(AVg,'lat') + nmsk = mct_avect_indexRA(AVg,'mask') + + n = 0 + Mdst = 1 + do j = 1,nygD + do i = 1,nxgD + n = n + 1 + Xdst(i,j) = AVg%rAttr(nlon,n) + Ydst(i,j) = AVg%rAttr(nlat,n) + if (abs(AVg%rAttr(nmsk,n)) < 0.5_R8) Mdst(i,j) = 0 + enddo + enddo + endif + + if (my_task == master_task) call mct_aVect_clean(AVg) +#endif + + allocate(Xdst(lsizeD),Ydst(lsizeD),Mdst(lsizeD)) + + nlon = mct_avect_indexRA(AVl,'lon') + nlat = mct_avect_indexRA(AVl,'lat') + nmsk = mct_avect_indexRA(AVl,'mask') + + Mdst = 1 + do n = 1,lsizeD + Xdst(n) = AVl%rAttr(nlon,n) + Ydst(n) = AVl%rAttr(nlat,n) + if (abs(AVl%rAttr(nmsk,n)) < 0.5_R8) Mdst(n) = 0 + enddo + + call mct_aVect_clean(AVl) + + !--- set map --- + + nsrc = nxgS*nygS + ndst = nxgD*nygD + call mct_gsmap_orderedPoints(gsmapD,my_task,points) + if (size(points) /= size(Xdst)) then + write(logunit,F01) ' ERROR: gsizeD ',size(points),size(Xdst) + call shr_sys_abort(subname//' ERROR points size') + endif + call shr_map_mapSet(shrmap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,ndst,points, & + trim(name),trim(type),trim(algo),trim(mask),trim(vect)) + deallocate(points) + deallocate(Xsrc,Ysrc,Msrc) + deallocate(Xdst,Ydst,Mdst) + + !--- convert map to sMatP --- + + lstrategy = 'Xonly' + if (present(strategy)) then + lstrategy = trim(strategy) + endif + + call shr_map_get(shrmap,shr_map_fs_nwts,nwts) + allocate(isrc(nwts),idst(nwts),wgts(nwts)) + call shr_map_get(shrmap,isrc,idst,wgts) + call shr_map_clean(shrmap) + + call mct_sMat_init(sMat0,ndst,nsrc,nwts) + + call mct_sMat_ImpLColI (sMat0,isrc,nwts) + call mct_sMat_ImpLRowI (sMat0,idst,nwts) + call mct_sMat_ImpMatrix(sMat0,wgts,nwts) + deallocate(isrc,idst,wgts) + + call mct_sMatP_Init(sMatP,sMat0,gsmapS,gsmapD,master_task,mpicom,compid) + + call mct_sMat_clean(sMat0) + +end subroutine shr_dmodel_mapSet_dest + +!=============================================================================== + +subroutine shr_dmodel_rearrGGrid( ggridi, ggrido, gsmap, rearr, mpicom ) + + implicit none + + !----- arguments ----- + type(mct_ggrid), intent(in) :: ggridi + type(mct_ggrid), intent(inout) :: ggrido + type(mct_gsmap), intent(in) :: gsmap + type(mct_rearr), intent(in) :: rearr + integer(IN) , intent(in) :: mpicom + + !----- local ----- + integer(IN) :: lsize ! lsize + real(R8) , pointer :: data(:) ! temporary + integer(IN), pointer :: idata(:) ! temporary + integer(IN) :: my_task ! local pe number + integer(IN) :: ier ! error code + character(*), parameter :: subname = '(shr_dmodel_rearrGGrid) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Determine MCT ggrid +!------------------------------------------------------------------------------- + + ! Initialize mct ggrid type + ! lat/lon in degrees, area in radians^2, mask is 1 (ocean), 0 (non-ocean) + + call mpi_comm_rank(mpicom,my_task,ier) + + lsize = mct_gsMap_lsize(gsMap, mpicom) + call mct_gGrid_init( ggrido, ggridi, lsize=lsize ) + + ! Determine global gridpoint number attribute, GlobGridNum, automatically in ggrid + + call mct_gsMap_orderedPoints(gsMap, my_task, idata) + call mct_gGrid_importIAttr(ggrido,'GlobGridNum',idata,lsize) + deallocate(idata) + + ! Initialize attribute vector with special value + + allocate(data(lsize)) + + data(:) = -9999.0_R8 + call mct_gGrid_importRAttr(ggrido,"lat" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"lon" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"area" ,data,lsize) + call mct_gGrid_importRAttr(ggrido,"aream",data,lsize) + data(:) = 0.0_R8 + call mct_gGrid_importRAttr(ggrido,"mask",data,lsize) + call mct_gGrid_importRAttr(ggrido,"frac",data,lsize) + + deallocate(data) + + call mct_rearr_rearrange(ggridi%data, ggrido%data, rearr) + +end subroutine shr_dmodel_rearrGGrid + +!=============================================================================== + +subroutine shr_dmodel_translateAV( avi, avo, avifld, avofld, rearr ) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(len=*),intent(in) :: avifld(:) ! input field names for translation + character(len=*),intent(in) :: avofld(:) ! output field names for translation + type(mct_rearr), intent(in),optional :: rearr ! rearranger for diff decomp + + !----- local ----- + integer(IN) :: n,k,ka,kb,kc,cnt ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: gsize ! gsize + integer(IN) :: nflds ! number of fields in avi + + type(mct_aVect) :: avtri,avtro ! translated av on input/output grid + character(CXX) :: ilist ! input list for translation + character(CXX) :: olist ! output list for translation + character(CX) :: cfld ! character field name + type(mct_string) :: sfld ! string field + integer(IN) :: ktrans + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + if (size(avifld) /= size(avofld)) then + write(logunit,*) subname,' ERROR": avi and avo fld list ',size(avifld),size(avofld) + call shr_sys_flush(logunit) + endif + ktrans = size(avifld) + + ! generate fld lists + nflds = mct_aVect_nRattr(avi) + cnt = 0 + do ka = 1,nflds + call mct_aVect_getRList(sfld,ka,avi) + cfld = mct_string_toChar(sfld) + call mct_string_clean(sfld) + + k = 0 + kb = 0 + kc = 0 + do while (kb == 0 .and. k < ktrans) + k = k + 1 + if (trim(avifld(k)) == trim(cfld)) then + kb = k + kc = mct_aVect_indexRA(avo,trim(avofld(kb)),perrWith='quiet') + if (ka > 0 .and. kc > 0) then + cnt = cnt + 1 + if (cnt == 1) then + ilist = trim(avifld(kb)) + olist = trim(avofld(kb)) + else + ilist = trim(ilist)//':'//trim(avifld(kb)) + olist = trim(olist)//':'//trim(avofld(kb)) + endif + endif + endif + enddo + enddo + + if (cnt > 0) then + lsize = mct_avect_lsize(avi) + call mct_avect_init(avtri,rlist=olist,lsize=lsize) + call mct_avect_Copy(avi,avtri,rList=ilist,TrList=olist) + + if (present(rearr)) then + lsize = mct_avect_lsize(avo) + call mct_avect_init(avtro,rlist=olist,lsize=lsize) + call mct_avect_zero(avtro) + call mct_rearr_rearrange(avtri, avtro, rearr) + call mct_avect_Copy(avtro,avo) + call mct_aVect_clean(avtro) + else + call mct_avect_Copy(avtri,avo) + endif + + call mct_aVect_clean(avtri) + endif + +end subroutine shr_dmodel_translateAV + +!=============================================================================== + +subroutine shr_dmodel_translate_list( avi, avo, avifld, avofld, ilist, olist, cnt) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(len=*),intent(in) :: avifld(:) ! input field names for translation + character(len=*),intent(in) :: avofld(:) ! output field names for translation + character(CL) ,intent(out) :: ilist ! input list for translation + character(CL) ,intent(out) :: olist ! output list for translation + integer(IN) ,intent(out) :: cnt ! indices + + + !----- local ----- + integer(IN) :: n,k,ka,kb,kc ! indices + integer(IN) :: lsize ! lsize + integer(IN) :: nflds ! number of fields in avi + character(CL) :: cfld ! character field name + type(mct_string) :: sfld ! string field + integer(IN) :: ktrans + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + if (size(avifld) /= size(avofld)) then + write(logunit,*) subname,' ERROR": avi and avo fld list ',size(avifld),size(avofld) + call shr_sys_flush(logunit) + endif + ktrans = size(avifld) + + ! generate fld lists + nflds = mct_aVect_nRattr(avi) + cnt = 0 + do ka = 1,nflds + call mct_aVect_getRList(sfld,ka,avi) + cfld = mct_string_toChar(sfld) + call mct_string_clean(sfld) + + k = 0 + kb = 0 + kc = 0 + do while (kb == 0 .and. k < ktrans) + k = k + 1 + if (trim(avifld(k)) == trim(cfld)) then + kb = k + kc = mct_aVect_indexRA(avo,trim(avofld(kb)),perrWith='quiet') + if (ka > 0 .and. kc > 0) then + cnt = cnt + 1 + if (cnt == 1) then + ilist = trim(avifld(kb)) + olist = trim(avofld(kb)) + else + ilist = trim(ilist)//':'//trim(avifld(kb)) + olist = trim(olist)//':'//trim(avofld(kb)) + endif + endif + endif + enddo + enddo + +end subroutine shr_dmodel_translate_list + +!=============================================================================== + +subroutine shr_dmodel_translateAV_list( avi, avo, ilist, olist, rearr ) + + implicit none + + !----- arguments ----- + type(mct_aVect), intent(in) :: avi ! input av + type(mct_aVect), intent(inout) :: avo ! output av + character(CL) ,intent(in) :: ilist ! input list for translation + character(CL) ,intent(in) :: olist ! output list for translation + type(mct_rearr), intent(in),optional :: rearr ! rearranger for diff decomp + + !----- local ----- + integer(IN) :: lsize ! lsize + type(mct_aVect) :: avtri,avtro ! translated av on input/output grid + character(*), parameter :: subname = '(shr_dmodel_translateAV) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Fill avo from avi +!------------------------------------------------------------------------------- + + lsize = mct_avect_lsize(avi) + call mct_avect_init(avtri,rlist=olist,lsize=lsize) + call mct_avect_Copy(avi,avtri,rList=ilist,TrList=olist) + + if (present(rearr)) then + lsize = mct_avect_lsize(avo) + call mct_avect_init(avtro,rlist=olist,lsize=lsize) + call mct_avect_zero(avtro) + call mct_rearr_rearrange(avtri, avtro, rearr) + call mct_avect_Copy(avtro,avo) + call mct_aVect_clean(avtro) + else + call mct_avect_Copy(avtri,avo) + endif + + call mct_aVect_clean(avtri) + +end subroutine shr_dmodel_translateAV_list + +!=============================================================================== + +end module shr_dmodel_mod diff --git a/share/csm_share/shr/shr_file_mod.F90 b/share/csm_share/shr/shr_file_mod.F90 new file mode 100644 index 000000000000..104c321f20f7 --- /dev/null +++ b/share/csm_share/shr/shr_file_mod.F90 @@ -0,0 +1,1013 @@ +!=============================================================================== +! SVN $Id: shr_file_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_file_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_file_mod.F90 --- Module to handle various file utilily functions. +! +! !DESCRIPTION: +! +! Miscilaneous methods to handle file and directory utilities as well as FORTRAN +! unit control. Also put/get local files into/from archival location +! +! File utilites used with CCSM Message passing: +! +! shr_file_stdio is the main example here, it changes the working directory, +! changes stdin and stdout to a given filename. +! +! This is needed because some implementations of MPI with MPMD so that +! each executable can run in a different working directory and redirect +! output to different files. +! +! File name archival convention, eg. +! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650) +! is extensible -- the existence of the option file name prefix, eg. "mss:", +! and optional arguments, eg. rtpd-3650 can be used to access site-specific +! storage devices. Based on CCM (atmosphere) getfile & putfile routines, but +! intended to be a more extensible, shared code. +! +! !REVISION HISTORY: +! 2006-05-08 E. Kluzek, Add in shr_file_mod and getUnit, freeUnif methods. +! 2000-??-?? B. Kauffman, original version circa 2000 +! +! !INTERFACE: ------------------------------------------------------------------ + +MODULE shr_file_mod + +! !USES: + + use shr_kind_mod ! defines kinds + use shr_sys_mod ! system calls + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + IMPLICIT none + + PRIVATE ! By default everything is private to this module + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_file_put ! Put a file to an archive location + public :: shr_file_get ! Get a file from an archive location + public :: shr_file_queryPrefix ! Get prefix type for a filename + public :: shr_file_getUnit ! Get a logical unit for reading or writing + public :: shr_file_freeUnit ! Free a logical unit + public :: shr_file_stdio ! change dir and stdin and stdout + public :: shr_file_chDir ! change current working directory + public :: shr_file_dirio ! change stdin and stdout + public :: shr_file_chStdIn ! change stdin (attach to a file) + public :: shr_file_chStdOut ! change stdout (attach to a file) + public :: shr_file_setIO ! open a log file from namelist + public :: shr_file_setLogUnit ! Reset the log unit number + public :: shr_file_setLogLevel ! Reset the logging debug level + public :: shr_file_getLogUnit ! Get the log unit number + public :: shr_file_getLogLevel ! Get the logging debug level + +! !PUBLIC DATA MEMBERS: + + ! Integer flags for recognized prefixes on file get/put operations + integer(SHR_KIND_IN), parameter, public :: shr_file_noPrefix = 0 ! no recognized prefix + integer(SHR_KIND_IN), parameter, public :: shr_file_nullPrefix = 1 ! null: + integer(SHR_KIND_IN), parameter, public :: shr_file_cpPrefix = 2 ! cp: + integer(SHR_KIND_IN), parameter, public :: shr_file_mssPrefix = 3 ! mss: + integer(SHR_KIND_IN), parameter, public :: shr_file_hpssPrefix = 4 ! hpss: + +!EOP + !--- unit numbers, users can ask for unit numbers from 0 to min, but getUnit + !--- won't give a unit below min, users cannot ask for unit number above max + !--- for backward compatability. + !--- eventually, recommend min as hard lower limit (tcraig, 9/2007) + integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10 ! Min unit number to give + integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99 ! Max unit number to give + logical, save :: UnitTag(0:shr_file_maxUnit) = .false. ! Logical units in use + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_put -- Put a file to an archival location. +! +! !DESCRIPTION: +! a generic, extensible put-local-file-into-archive routine +! USAGE: +! call shr_file_put(rcode,"foo","/home/user/foo") +! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" ) +! call shr_file_put(rcode,"foo","cp:/home/user/foo",remove=.true.) +! if ( rcode /= 0 ) call shr_sys_abort( "error copying foo" ) +! call shr_file_put(rcode,"foo","mss:/USER/foo",rtpd=3650) +! if ( rcode /= 0 ) call shr_sys_abort( "error archiving foo to MSS" ) +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_put(rcode,loc_fn,rem_fn,passwd,rtpd,async,remove) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero -- error) + character(*), intent(in) :: loc_fn ! local filename + character(*), intent(in) :: rem_fn ! remote filename + character(*), intent(in),optional :: passwd ! password + integer(SHR_KIND_IN),intent(in),optional :: rtpd ! MSS retention period + logical, intent(in),optional :: async ! true <=> asynchronous put + logical, intent(in),optional :: remove ! true <=> rm after put + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rtpd2 ! MSS retention period + logical :: remove2 ! true <=> rm after put + logical :: async2 ! true <=> asynchronous put + character(SHR_KIND_CL) :: passwd2 ! password + character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix + character(SHR_KIND_CL) :: cmd ! command sent to system call + integer(SHR_KIND_IN) :: prefix ! remote file prefix type + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_put) ' + character(*),parameter :: F00 = "('(shr_file_put) ',4a)" + character(*),parameter :: F01 = "('(shr_file_put) ',a,i3,2a)" + character(*),parameter :: F02 = "(a,i4)" + +!------------------------------------------------------------------------------- +! Notes: +! - On some machines the system call will not return a valid error code +! - when things are sent asynchronously, there probably won't be a error code +! returned. +!------------------------------------------------------------------------------- + + remove2 =.false. ; if ( PRESENT(remove )) remove2 = remove + async2 =.true. ; if ( PRESENT(async )) async2 = async + passwd2 = " " ; if ( PRESENT(passwd )) passwd2 = passwd + rtpd2 = 365 ; if ( PRESENT(rtpd )) rtpd2 = rtpd + rcode = 0 + prefix = shr_file_queryPrefix( rem_fn ) + + if ( trim(rem_fn) == trim(loc_fn) ) then + !------------------------------------------------------ + ! (remote file name) == (local file name) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: remote file = local file = '//trim(loc_fn) + rcode = 0 + else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then + !------------------------------------------------------ + ! put via unix cp + !------------------------------------------------------ + rfn = rem_fn + if ( rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn)) + cmd = '/bin/cp -f '//trim(loc_fn)//' '//trim(rfn) + if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn) + if (async2 ) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_mssPrefix )then + !------------------------------------------------------ + ! put onto NCAR's MSS + !------------------------------------------------------ + if (rtpd2 > 9999) rtpd2 = 9999 + write(cmd,F02) '/usr/local/bin/msrcp -period ',rtpd2 + if (async2 .and. (.not. remove2) ) cmd = trim(cmd)//' -async ' + if (len_trim(passwd2) > 0 ) cmd = trim(cmd)//' -wpwd '//trim(passwd) + cmd = trim(cmd)//' '//trim(loc_fn)//' '//trim(rem_fn) + if (remove2) cmd = trim(cmd)//' && /bin/rm -f '//trim(loc_fn) + if (async2 .and. remove2 ) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_hpssPrefix )then + !------------------------------------------------------ + ! put onto LANL's hpss + !------------------------------------------------------ + rcode = -1 + cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn) + write(s_logunit,F00) 'ERROR: hpss option not yet implemented' + call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' ) + else if ( prefix == shr_file_nullPrefix )then + ! do nothing + cmd = "null prefix => no file archival, do nothing" + rcode = 0 + end if + + if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd) + +END SUBROUTINE shr_file_put + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_get -- Get a file from archival location. +! +! !DESCRIPTION: +! a generic, extensible get-local-file-from-archive routine +! +! USAGE: +! call shr_file_get(rcode,"foo","/home/user/foo") +! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" ) +! call shr_file_get(rcode,"foo","cp:/home/user/foo",remove=.true.) +! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo" ) +! call shr_file_get(rcode,"foo","mss:/USER/foo",clobber=.true.) +! if ( rcode /= 0 ) call shr_sys_abort( "error getting file foo from MSS" ) +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_get(rcode,loc_fn,rem_fn,passwd,async,clobber) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: rcode ! return code (non-zero means error) + character(*) ,intent(in) :: loc_fn ! local filename + character(*) ,intent(in) :: rem_fn ! remote filename + character(*) ,intent(in),optional :: passwd ! password + logical ,intent(in),optional :: async ! true <=> asynchronous get + logical ,intent(in),optional :: clobber ! true <=> clobber existing file + +!EOP + + !----- local ----- + logical :: async2 ! true <=> asynchronous get + logical :: clobber2 ! true <=> clobber existing file + logical :: exists ! true <=> local file a ready exists + character(SHR_KIND_CL) :: passwd2 ! password + character(SHR_KIND_CL) :: rfn ! rem_fn without the destination prefix + character(SHR_KIND_CL) :: cmd ! command sent to system call + integer(SHR_KIND_IN) :: prefix ! remote file prefix type + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_get) ' + character(*),parameter :: F00 = "('(shr_file_get) ',4a)" + character(*),parameter :: F01 = "('(shr_file_get) ',a,i3,2a)" + +!------------------------------------------------------------------------------- +! Notes: +! - On some machines the system call will not return a valid error code +! - When things are sent asynchronously, there probably won't be a error code +! returned. +!------------------------------------------------------------------------------- + + passwd2 = " " ; if (PRESENT(passwd )) passwd2 = passwd + async2 = .false. ; if (PRESENT(async )) async2 = async + clobber2 = .false. ; if (PRESENT(clobber)) clobber2 = clobber + rcode = 0 + + inquire(file=trim(loc_fn),exist=exists) + prefix = shr_file_queryPrefix( rem_fn ) + + if ( exists .and. .not. clobber2 ) then + !------------------------------------------------------ + ! (file exists) and (don't clobber) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: file exists & no-clobber for '//trim(loc_fn) + rcode = 0 + else if ( trim(rem_fn) == trim(loc_fn) ) then + !------------------------------------------------------ + ! (remote file name) == (local file name) => do nothing + !------------------------------------------------------ + cmd = 'do nothing: remote file = local file for '//trim(loc_fn) + rcode = 0 + else if ( prefix == shr_file_cpPrefix .or. prefix == shr_file_noPrefix )then + !------------------------------------------------------ + ! get via unix cp + !------------------------------------------------------ + rfn = rem_fn ! remove prefix from this temp file name + if (rem_fn(1:3) == "cp:") rfn = rem_fn(4:len_trim(rem_fn)) + cmd = '/bin/cp -f '//trim(rfn)//' '//trim(loc_fn) + if (async2) cmd = trim(cmd)//' & ' + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_mssPrefix )then + !------------------------------------------------------ + ! get from NCAR's MSS + !------------------------------------------------------ + cmd = '/usr/local/bin/msrcp ' + if (async2) cmd = trim(cmd)//' -async ' + cmd = trim(cmd)//' '//trim(rem_fn)//' '//trim(loc_fn) + call shr_sys_system(trim(cmd),rcode) + else if ( prefix == shr_file_hpssPrefix )then + !------------------------------------------------------ + ! get from LANL's hpss + !------------------------------------------------------ + rcode = -1 + cmd = 'rem_fn='//trim(rem_fn)//' loc_fn='//trim(loc_fn) + write(s_logunit,F00) 'ERROR: hpss option not yet implemented' + call shr_sys_abort( subName//'ERROR: hpss option not yet implemented' ) + else if ( prefix == shr_file_nullPrefix )then + ! do nothing + cmd = "null prefix => no file retrieval, do nothing" + rcode = 0 + end if + + if (s_loglev > 0) write(s_logunit,F01) 'rcode =',rcode,' cmd = ', trim(cmd) + +END SUBROUTINE shr_file_get + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_queryPrefix -- Get the prefix type from a filepath. +! +! !DESCRIPTION: +! +! !INTERFACE: ------------------------------------------------------------------ + +integer(SHR_KIND_IN) FUNCTION shr_file_queryPrefix( filepath, prefix ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*), intent(in) :: filepath ! Input filepath + character(*), intent(out), optional :: prefix ! Output prefix description + +!EOP + + !----- local ----- + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ( filepath(1:5) == "null:" )then + shr_file_queryPrefix = shr_file_nullPrefix + if ( present(prefix) ) prefix = "null:" + else if( filepath(1:3) == "cp:" )then + shr_file_queryPrefix = shr_file_cpPrefix + if ( present(prefix) ) prefix = "cp:" + else if( filepath(1:4) == "mss:" )then + shr_file_queryPrefix = shr_file_mssPrefix + if ( present(prefix) ) prefix = "mss:" + else if( filepath(1:5) == "hpss:" )then + shr_file_queryPrefix = shr_file_hpssPrefix + if ( present(prefix) ) prefix = "hpss:" + else + shr_file_queryPrefix = shr_file_noPrefix + if ( present(prefix) ) prefix = "" + end if + +END FUNCTION shr_file_queryPrefix + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number +! +! !DESCRIPTION: Get the next free FORTRAN unit number. +! +! !REVISION HISTORY: +! 2005-Dec-14 - E. Kluzek - creation +! +! !INTERFACE: ------------------------------------------------------------------ + +INTEGER FUNCTION shr_file_getUnit ( unit ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in),optional :: unit ! desired unit number + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! loop index + logical :: opened ! If unit opened or not + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_getUnit) ' + character(*),parameter :: F00 = "('(shr_file_getUnit) ',A,I4,A)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (present (unit)) then + inquire( unit, opened=opened ) + if (unit < 0 .or. unit > shr_file_maxUnit) then + write(s_logunit,F00) 'invalid unit number request:', unit + call shr_sys_abort( 'ERROR: bad input unit number' ) + else if (opened .or. UnitTag(unit) .or. unit == 0 .or. unit == 5 & + .or. unit == 6) then + write(s_logunit,F00) 'unit number ', unit, ' is already in use' + call shr_sys_abort( 'ERROR: Input unit number already in use' ) + else + shr_file_getUnit = unit + UnitTag (unit) = .true. + return + end if + + else + ! --- Choose first available unit other than 0, 5, or 6 ------ + do n=shr_file_maxUnit, shr_file_minUnit, -1 + inquire( n, opened=opened ) + if (n == 5 .or. n == 6 .or. opened) then + cycle + end if + if ( .not. UnitTag(n) ) then + shr_file_getUnit = n + UnitTag(n) = .true. + return + end if + end do + end if + + call shr_sys_abort( subName//': Error: no available units found' ) + +END FUNCTION shr_file_getUnit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number +! +! !DESCRIPTION: Free up the given unit number +! +! !REVISION HISTORY: +! 2005-Dec-14 - E. Kluzek - creation +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_freeUnit ( unit) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: unit ! unit number to be freed + +!EOP + + !----- local ----- + + !----- formats ----- + character(*), parameter :: subName = '(shr_file_freeUnit) ' + character(*), parameter :: F00 = "('(shr_file_freeUnit) ',A,I4,A)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (unit < 0 .or. unit > shr_file_maxUnit) then + if (s_loglev > 0) write(s_logunit,F00) 'invalid unit number request:', unit + else if (unit == 0 .or. unit == 5 .or. unit == 6) then + call shr_sys_abort( subName//': Error: units 0, 5, and 6 must not be freed' ) + else if (UnitTag(unit)) then + UnitTag (unit) = .false. + else + if (s_loglev > 0) write(s_logunit,F00) 'unit ', unit, ' was not in use' + end if + + return + +END SUBROUTINE shr_file_freeUnit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_stdio -- Change working directory, and redirect stdin/stdout +! +! !DESCRIPTION: +! 1) change the cwd (current working directory) and +! 2) redirect stdin & stdout (units 5 & 6) to named files, +! where the desired cwd & files are specified by namelist file. +! +! Normally this is done to work around limitations in the execution syntax +! of common MPI implementations. For example, SGI's mpirun syntax is not +! flexible enough to allow MPMD models to select different execution +! directories or to redirect stdin & stdout on the command line. +! Such functionality is highly desireable for CCSM purposes. +! ie. mpirun can't handle this: +! unix> cd /usr/tmp/jdoe/csm/case01/atm ; atm < atm.parm > atm.log & +! unix> cd /usr/tmp/jdoe/csm/case01/cpl ; cpl < cpl.parm > cpl.log & +! etc. +! +! ASSUMPTIONS: +! o if the cwd, stdin, or stdout are to be changed, there must be a namelist +! file in the cwd named _stdio.nml where is provided via +! subroutine dummy argument. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_stdio(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: model ! used to construct env varible name + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_stdio) ' + character(*),parameter :: F00 = "('(shr_file_stdio) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call shr_file_chdir (model) ! changes cwd + call shr_file_chStdOut(model) ! open units 5 & 6 to named files + call shr_file_chStdIn (model) ! open units 5 & 6 to named files + +END SUBROUTINE shr_file_stdio + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_chdir -- Change working directory. +! +! !DESCRIPTION: +! change the cwd (current working directory), see shr_file_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_chdir(model, rcodeOut) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env varible name + integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code + +!EOP + + !--- local --- + character(SHR_KIND_CL) :: dir ! directory to cd to + integer (SHR_KIND_IN) :: rcode ! Return error code + character(SHR_KIND_CL) :: filename ! namelist file to read + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chdir) ' + character(*),parameter :: F00 = "('(shr_file_chdir) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, dirOut=dir, rcodeOut=rcode ) + if (dir /= "nochange") then + call shr_sys_chdir(dir ,rcode) + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", changed cwd to ",trim(dir) + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", cwd has *not* been changed" + rcode = 1 + endif + if ( present(rcodeOut) ) rcodeOut = rcode + +END SUBROUTINE shr_file_chdir + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_dirio --- Change stdin and stdout. +! +! !DESCRIPTION: +! change the stdin & stdout (units 5 & 6), see shr_file_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_dirio(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: model ! used to construct env varible name + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = '(shr_file_dirio) ' + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_chStdIn (model) + call shr_file_chStdOut(model) + +END SUBROUTINE shr_file_dirio + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_chStdIn -- Change stdin +! +! !DESCRIPTION: +! change the stdin (unit 5), see shr_file_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_chStdIn( model, NLFilename, rcodeOut ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env var name + character(SHR_KIND_CL),intent(out),optional :: NLFilename ! open unit 5 to this + integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code + +!EOP + + !--- local --- + character(SHR_KIND_CL) :: stdin ! open unit 5 to this file + character(SHR_KIND_CL) :: nlfile ! Namelist filename for model to read from + character(SHR_KIND_CL) :: filename ! namelist file to read + integer (SHR_KIND_IN) :: rcode ! return code + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chStdIn) ' + character(*),parameter :: F00 = "('(shr_file_chStdIn) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, stdinOut=stdin, & + nlfileOut=nlfile, rcodeOut=rcode ) + if (stdin /= "nochange") then + open(unit=5,file=stdin ,status='UNKNOWN',iostat=rcode) + if ( rcode /= 0 )then + if (s_loglev > 0) & + write(s_logunit,F00) "read ",trim(filename),': error opening file as unit 5:', & + trim(nlfile) + else + if (s_loglev > 0) & + write(s_logunit,F00) "read ",trim(filename),': unit 5 connected to ', & + trim(stdin) + end if + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 5 has *not* been redirected' + endif + if ( len_trim(nlfile) > 0) then + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': read namelist from file:',trim(nlfile) + if ( .not. present(NLFilename) )then + if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename NOT present" + rcode = 7 + end if + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename),", " + if ( present(NLFilename) )then + if (s_loglev > 0) write(s_logunit,F00) "error: namelist filename present, but null" + rcode = 8 + end if + endif + if ( present(NLFilename) ) NLFilename = nlfile + if ( present(rcodeOut) ) rcodeOut = rcode + +END SUBROUTINE shr_file_chStdIn + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_stdout -- Change stdout +! +! !DESCRIPTION: +! change the stdout (unit 6), see shr_file_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_chStdOut(model,rcodeOut) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(*) ,intent(in) :: model ! used to construct env varible name + integer(SHR_KIND_IN),intent(out),optional :: rcodeOut ! Return error code +!EOP + + !--- local --- + character(SHR_KIND_CL) :: filename ! namelist file to read + character(SHR_KIND_CL) :: stdout ! open unit 6 to this file + integer (SHR_KIND_IN) :: rcode ! return code + + !--- formats --- + character(*),parameter :: subName = '(shr_file_chStdOut) ' + character(*),parameter :: F00 = "('(shr_file_chStdOut) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + call shr_file_stdioReadNL( model, filename, stdoutOut=stdout, & + rcodeOut=rcode ) + if (stdout /= "nochange") then + close(6) + open(unit=6,file=stdout,position='APPEND') + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 6 connected to ',trim(stdout) + call shr_sys_flush(s_logunit) + else + if (s_loglev > 0) write(s_logunit,F00) "read ",trim(filename), & + ': unit 6 has *not* been redirected' + rcode = 1 + endif + + if ( present(rcodeOut) ) rcodeOut = rcode + +END SUBROUTINE shr_file_chStdOut + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_stdioReadNL -- read in stdio namelist +! +! !DESCRIPTION: +! Read in the stdio namelist for any given model type. Return any of the +! needed input namelist variables as optional arguments. Return "nochange" in +! dir, stdin, or stdout if shouldn't change. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_stdioReadNL( model, filename, dirOut, stdinOut, stdoutOut, & + NLFileOut, rcodeOut ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: model ! used to construct env varible name + character(SHR_KIND_CL),intent(out) :: filename ! nml file to read from unit 5 + character(SHR_KIND_CL),intent(out),optional :: NLFileOut ! open unit 6 to this file + character(SHR_KIND_CL),intent(out),optional :: dirOut ! directory to cd to + character(SHR_KIND_CL),intent(out),optional :: stdinOut ! open unit 5 to this file + character(SHR_KIND_CL),intent(out),optional :: stdoutOut ! open unit 6 to this file + integer (SHR_KIND_IN),intent(out),optional :: rcodeOut ! return code + +!EOP + + !--- local --- + logical :: exists ! true iff file exists + character(SHR_KIND_CL) :: dir ! directory to cd to + character(SHR_KIND_CL) :: stdin ! open unit 5 to this file + character(SHR_KIND_CL) :: stdout ! open unit 6 to this file + character(SHR_KIND_CL) :: NLFile ! namelist file to read seperately + integer (SHR_KIND_IN) :: rcode ! return code + integer (SHR_KIND_IN) :: unit ! Unit to read from + + namelist / stdio / dir,stdin,stdout,NLFile + + !--- formats --- + character(*),parameter :: subName = '(shr_file_stdioReadNL) ' + character(*),parameter :: F00 = "('(shr_file_stdioReadNL) ',4a)" + character(*),parameter :: F01 = "('(shr_file_stdioReadNL) ',2a,i6)" + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + rcode = 0 + dir = "nochange" + stdin = "nochange" + stdout = "nochange" + NLFile = " " + + filename = trim(model)//"_stdio.nml" ! eg. file="cpl_stdio.nml" + inquire(file=filename,exist=exists) + + if (.not. exists) then + if (s_loglev > 0) write(s_logunit,F00) "file ",trim(filename),& + & " doesn't exist, can not read stdio namelist from it" + rcode = 9 + else + unit = shr_file_getUnit() + open (unit,file=filename,action="READ") + read (unit,nml=stdio,iostat=rcode) + close(unit) + call shr_file_freeUnit( unit ) + if (rcode /= 0) then + write(s_logunit,F01) 'ERROR: reading ',trim(filename),': iostat=',rcode + call shr_sys_abort(subName//" ERROR reading "//trim(filename) ) + end if + endif + if ( len_trim(NLFile) > 0 .and. trim(stdin) /= "nochange" )then + write(s_logunit,F00) "Error: input namelist:" + write(s_logunit,nml=stdio) + call shr_sys_abort(subName//" ERROR trying to both redirect AND "// & + "open namelist filename" ) + end if + if ( present(NLFileOut) ) NLFileOut = NLFile + if ( present(dirOut) ) dirOut = dir + if ( present(stdinOut) ) stdinOut = stdin + if ( present(stdoutOut) ) stdoutOut = stdout + if ( present(rcodeOut) ) rcodeOut = rcode + +END SUBROUTINE shr_file_stdioReadNL + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_setIO -- read in stdio namelist +! +! !DESCRIPTION: +! This opens a namelist file specified as an argument and then opens +! a log file associated with the unit argument. This may be extended +! in the future. +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_setIO( nmlfile, funit) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(len=*) ,intent(in) :: nmlfile ! namelist filename + integer(SHR_KIND_IN),intent(in) :: funit ! unit number for log file + +!EOP + + !--- local --- + logical :: exists ! true if file exists + character(SHR_KIND_CL) :: diri ! directory to cd to + character(SHR_KIND_CL) :: diro ! directory to cd to + character(SHR_KIND_CL) :: logfile ! open unit 6 to this file + integer(SHR_KIND_IN) :: unit ! unit number + integer(SHR_KIND_IN) :: rcode ! error code + + namelist / modelio / diri,diro,logfile + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setIO) ' + character(*),parameter :: F00 = "('(shr_file_setIO) ',4a)" + character(*),parameter :: F01 = "('(shr_file_setIO) ',2a,i6)" + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + diri = "." + diro = "." + logfile = "" + + inquire(file=nmlfile,exist=exists) + + if (.not. exists) then + if (s_loglev > 0) write(s_logunit,F00) "file ",trim(nmlfile)," nonexistent" + return + else + unit = shr_file_getUnit() + open (unit,file=nmlfile,action="READ") + read (unit,nml=modelio,iostat=rcode) + close(unit) + call shr_file_freeUnit( unit ) + if (rcode /= 0) then + write(s_logunit,F01) 'ERROR: reading ',trim(nmlfile),': iostat=',rcode + call shr_sys_abort(subName//" ERROR reading "//trim(nmlfile) ) + end if + endif + + if (len_trim(logfile) > 0) then + open(funit,file=trim(diro)//"/"//trim(logfile)) + else + if (s_loglev > 0) write(s_logunit,F00) "logfile not opened" + endif + +END SUBROUTINE shr_file_setIO + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_setLogUnit -- Set the Log I/O Unit number +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_setLogUnit(unit) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: unit ! new unit number + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setLogUnit) ' + character(*),parameter :: F00 = "('(shr_file_setLogUnit) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: Caller must be sure it's a valid unit number +!------------------------------------------------------------------------------- + + if (s_loglev > 1 .and. s_logunit-unit /= 0) then + write(s_logunit,*) subName,': reset log unit number from/to ',s_logunit, unit + write( unit,*) subName,': reset log unit number from/to ',s_logunit, unit + endif + + s_logunit = unit + +END SUBROUTINE shr_file_setLogUnit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_setLogLevel -- Set the Log I/O Unit number +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_setLogLevel(newlevel) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: newlevel ! new log level + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_setLogLevel) ' + character(*),parameter :: F00 = "('(shr_file_setLogLevel) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (s_loglev+newlevel > 2 .and. s_loglev-newlevel /= 0) & + write(s_logunit,*) subName,': reset log level from/to ',s_loglev, newlevel + + s_loglev = newlevel + +END SUBROUTINE shr_file_setLogLevel + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_getLogUnit -- Set the Log I/O Unit number +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_getLogUnit(unit) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: unit ! new unit number + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_getLogUnit) ' + character(*),parameter :: F00 = "('(shr_file_getLogUnit) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + unit = s_logunit + +END SUBROUTINE shr_file_getLogUnit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_getLogLevel -- Set the Log I/O Unit number +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_getLogLevel(curlevel) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(out) :: curlevel ! new log level + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_file_getLogLevel) ' + character(*),parameter :: F00 = "('(shr_file_getLogLevel) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + curlevel = s_loglev + +END SUBROUTINE shr_file_getLogLevel + +!=============================================================================== +!=============================================================================== + +END MODULE shr_file_mod diff --git a/share/csm_share/shr/shr_flux_mod.F90 b/share/csm_share/shr/shr_flux_mod.F90 new file mode 100644 index 000000000000..c1808f86543a --- /dev/null +++ b/share/csm_share/shr/shr_flux_mod.F90 @@ -0,0 +1,1477 @@ +!=============================================================================== +! SVN $Id: shr_flux_mod.F90 70843 2015-05-26 22:42:14Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branches/aofluxd/shr/shr_flux_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: flux_mod -- CCSM shared flux calculations. +! +! !DESCRIPTION: +! +! CCSM shared flux calculations. +! +! !REVISION HISTORY: +! 2006-Nov-07 - B. Kauffman - first version, code taken/migrated from cpl6 +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_flux_mod + +! !USES: + + use shr_kind_mod ! shared kinds + use shr_const_mod ! shared constants + use shr_sys_mod ! shared system routines + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + + private ! default private + +! !PUBLIC TYPES: + + ! none + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_flux_atmOcn ! computes atm/ocn fluxes + public :: shr_flux_atmOcn_diurnal ! computes atm/ocn fluxes with diurnal cycle + public :: shr_flux_atmIce ! computes atm/ice fluxes + public :: shr_flux_MOstability ! boundary layer stability scales/functions + public :: shr_flux_adjust_constants ! adjust constant values used in flux calculations. + +! !PUBLIC DATA MEMBERS: + + integer(SHR_KIND_IN),parameter,public :: shr_flux_MOwScales = 1 ! w scales option + integer(SHR_KIND_IN),parameter,public :: shr_flux_MOfunctions = 2 ! functions option + real (SHR_KIND_R8),parameter,public :: shr_flux_MOgammaM = 3.59_SHR_KIND_R8 + real (SHR_KIND_R8),parameter,public :: shr_flux_MOgammaS = 7.86_SHR_KIND_R8 + +!EOP + + !--- rename kinds for local readability only --- + integer,parameter :: R8 = SHR_KIND_R8 ! 8 byte real + integer,parameter :: IN = SHR_KIND_IN ! native/default integer + + integer,parameter :: debug = 0 ! internal debug level + +! The follow variables are not declared as parameters so that they can be +! adjusted to support aquaplanet and potentially other simple model modes. +! The shr_flux_adjust_constants subroutine is called to set the desired +! values. The default values are from shr_const_mod. Currently they are +! only used by the shr_flux_atmocn and shr_flux_atmice routines. + real(R8) :: loc_zvir = shr_const_zvir + real(R8) :: loc_cpdair = shr_const_cpdair + real(R8) :: loc_cpvir = shr_const_cpvir + real(R8) :: loc_karman = shr_const_karman + real(R8) :: loc_g = shr_const_g + real(R8) :: loc_latvap = shr_const_latvap + real(R8) :: loc_latice = shr_const_latice + real(R8) :: loc_stebol = shr_const_stebol + +!=============================================================================== +contains +!=============================================================================== +!=============================================================================== +subroutine shr_flux_adjust_constants( & + zvir, cpair, cpvir, karman, gravit, & + latvap, latice, stebol) + + ! Adjust local constants. Used to support simple models. + + real(R8), optional, intent(in) :: zvir + real(R8), optional, intent(in) :: cpair + real(R8), optional, intent(in) :: cpvir + real(R8), optional, intent(in) :: karman + real(R8), optional, intent(in) :: gravit + real(R8), optional, intent(in) :: latvap + real(R8), optional, intent(in) :: latice + real(R8), optional, intent(in) :: stebol + !---------------------------------------------------------------------------- + + if (present(zvir)) loc_zvir = zvir + if (present(cpair)) loc_cpdair = cpair + if (present(cpvir)) loc_cpvir = cpvir + if (present(karman)) loc_karman = karman + if (present(gravit)) loc_g = gravit + if (present(latvap)) loc_latvap = latvap + if (present(latice)) loc_latice = latice + if (present(stebol)) loc_stebol = stebol + +end subroutine shr_flux_adjust_constants +!=============================================================================== +! !BOP ========================================================================= +! +! !IROUTINE: shr_flux_atmOcn -- internal atm/ocn flux calculation +! +! !DESCRIPTION: +! +! Internal atm/ocn flux calculation +! +! !REVISION HISTORY: +! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 +! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity +! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large +! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot ,prec_gust, gust_fac, & + & qbot ,rbot ,tbot ,us ,vs , & + & ts ,mask ,sen ,lat ,lwup , & + & evap ,taux ,tauy ,tref ,qref , & + & duu10n, ustar_sv ,re_sv ,ssq_sv, & + & missval ) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + real(R8) ,intent(in) :: prec_gust (nMax) ! atm precip for convective gustiness (kg/m^3) + real(R8) ,intent(in) :: gust_fac ! wind gustiness factor + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + real(R8),intent(in) ,optional :: missval ! masked value + +! !EOP + + !--- local constants -------------------------------- + real(R8),parameter :: umin = 0.5_R8 ! minimum wind speed (m/s) + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: thvbot ! virtual temperature (K) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: bn ! exchange coef funct for interpolation + real(R8) :: bh ! exchange coef funct for interpolation + real(R8) :: fac ! vertical interpolation factor + real(R8) :: spval ! local missing value + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + real(R8) :: cdn ! function: neutral drag coeff at 10m + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: ugust ! function: gustiness as a function of convective rainfall + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + real(R8) :: gprec ! dummy arg ~ ? + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + + ! Convective gustiness appropriate for input precipitation. + ! Following Redelsperger et al. (2000, J. Clim) + ! Ug = log(1.0+6.69R-0.476R^2) + ! Coefficients X by 8640 for mm/s (from cam) -> cm/day (for above forumla) + ugust(gprec) = gust_fac*log(1._R8+57801.6_R8*gprec-3.55332096e7_R8*(gprec**2.0_R8)) + + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(shr_flux_atmOcn) ' + character(*),parameter :: F00 = "('(shr_flux_atmOcn) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: +! computes atm/ocn surface fluxes +! +! NOTES: +! o all fluxes are positive downward +! o net heat flux = net sw + lw up + lw down + sen + lat +! o here, tstar = /U*, and qstar = /U*. +! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) +! +! ASSUMPTIONS: +! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 +! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable +! ctn = .0180 sqrt(cdn), stable +! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) +! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) +!------------------------------------------------------------------------------- + + if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) "enter" + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + + al2 = log(zref/ztref) + + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + !--- vmag+ugust (convective gustiness) Limit to a max precip 6 cm/day = 0.00069444 mm/s. + vmag = max(umin, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) + ugust(min(prec_gust(n),6.94444e-4_R8))) + + thvbot = thbot(n) * (1.0_R8 + loc_zvir * qbot(n)) ! virtual temp (K) + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - ts(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + alz = log(zbot(n)/zref) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) + + !------------------------------------------------------------ + ! first estimate of Z/L and ustar, tstar and qstar + !------------------------------------------------------------ + + !--- neutral coefficients, z/L = 0.0 --- + stable = 0.5_R8 + sign(0.5_R8 , delt) + rdn = sqrt(cdn(vmag)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + + !--- compute stability & evaluate all stability functions --- + hol = loc_karman*loc_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/loc_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- update transfer coeffs at 10m and neutral stability --- + rdn = sqrt(cdn(u10n)) + ren = 0.0346_R8 + rhn = (1.0_R8-stable)*0.0327_R8 + stable * 0.018_R8 + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar using updated, shifted coeffs -- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !------------------------------------------------------------ + ! iterate to converge on Z/L, ustar, tstar and qstar + !------------------------------------------------------------ + + !--- compute stability & evaluate all stability functions --- + hol = loc_karman*loc_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/loc_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coeffs --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + u10n = vmag * rd/rdn + + !--- update transfer coeffs at 10m and neutral stability --- + rdn = sqrt(cdn(u10n)) + ren = 0.0346_R8 + rhn = (1.0_R8 - stable)*0.0327_R8 + stable * 0.018_R8 + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar using updated, shifted coeffs --- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !------------------------------------------------------------ + ! compute the fluxes + !------------------------------------------------------------ + + tau = rbot(n) * ustar * ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = cp * tau * tstar / ustar + lat (n) = loc_latvap * tau * qstar / ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/loc_latvap + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/loc_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/loc_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv(n) = re + if (present(ssq_sv )) ssq_sv(n) = ssq + + else + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + endif + ENDDO + +END subroutine shr_flux_atmOcn + +!=============================================================================== +! !BOP ========================================================================= +! +! !IROUTINE: shr_flux_atmOcn_diurnal -- internal atm/ocn flux calculation +! +! !DESCRIPTION: +! +! Internal atm/ocn flux calculation +! +! !REVISION HISTORY: +! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 +! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity +! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large +! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_flux_atmOcn_diurnal & + (nMax ,zbot ,ubot ,vbot ,thbot , & + qbot ,rbot ,tbot ,us ,vs , & + ts ,mask ,sen ,lat ,lwup , & + evap ,taux ,tauy ,tref ,qref , & + uGust, lwdn , swdn , swup, prec , & + swpen, ocnsal, ocn_prognostic, flux_diurnal, & + latt, long , warm , salt , speed, regime, & + warmMax, windMax, qSolAvg, windAvg, & + warmMaxInc, windMaxInc, qSolInc, windInc, nInc, & + tBulk, tSkin, tSkin_day, tSkin_night, & + cSkin, cSkin_night, secs ,dt, & + duu10n, ustar_sv ,re_sv ,ssq_sv, & + missval ) +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + + !--- new arguments ------------------------------- + real(R8),intent(inout) :: swpen (nMax) ! NEW + real(R8),intent(inout) :: ocnsal(nMax) ! NEW (kg/kg) + logical ,intent(in) :: ocn_prognostic ! NEW + logical ,intent(in) :: flux_diurnal ! NEW logical for diurnal on/off + + real(R8),intent(in) :: uGust (nMax) ! NEW not used + real(R8),intent(in) :: lwdn (nMax) ! NEW + real(R8),intent(in) :: swdn (nMax) ! NEW + real(R8),intent(in) :: swup (nMax) ! NEW + real(R8),intent(in) :: prec (nMax) ! NEW + real(R8),intent(in) :: latt (nMax) ! NEW + real(R8),intent(in) :: long (nMax) ! NEW + real(R8),intent(inout) :: warm (nMax) ! NEW + real(R8),intent(inout) :: salt (nMax) ! NEW + real(R8),intent(inout) :: speed (nMax) ! NEW + real(R8),intent(inout) :: regime(nMax) ! NEW + real(R8),intent(out) :: warmMax(nMax) ! NEW + real(R8),intent(out) :: windMax(nMax) ! NEW + real(R8),intent(inout) :: qSolAvg(nMax) ! NEW + real(R8),intent(inout) :: windAvg(nMax) ! NEW + real(R8),intent(inout) :: warmMaxInc(nMax) ! NEW + real(R8),intent(inout) :: windMaxInc(nMax) ! NEW + real(R8),intent(inout) :: qSolInc(nMax) ! NEW + real(R8),intent(inout) :: windInc(nMax) ! NEW + real(R8),intent(inout) :: nInc(nMax) ! NEW + + real(R8),intent(out) :: tBulk (nMax) ! NEW + real(R8),intent(out) :: tSkin (nMax) ! NEW + real(R8),intent(out) :: tSkin_day (nMax) ! NEW + real(R8),intent(out) :: tSkin_night (nMax) ! NEW + real(R8),intent(out) :: cSkin (nMax) ! NEW + real(R8),intent(out) :: cSkin_night (nMax) ! NEW + integer(IN),intent(in) :: secs ! NEW elsapsed seconds in day (GMT) + integer(IN),intent(in) :: dt ! NEW + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + +! !EOP + + + !--- local constants -------------------------------- + real(R8),parameter :: umin = 0.5_R8 ! minimum wind speed (m/s) + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + integer(IN),parameter :: iMax = 3 + + real(R8),parameter :: lambdaC = 6.0_R8 + real(R8),parameter :: lambdaL = 0.0_R8 + real(R8),parameter :: doLMax = 1.0_R8 + real(R8),parameter :: pwr = 0.2_R8 + real(R8),parameter :: Rizero = 1.0_R8 + real(R8),parameter :: NUzero = 40.0e-4_R8 + real(R8),parameter :: Prandtl = 1.0_R8 + real(R8),parameter :: kappa0 = 0.2e-4_R8 + + real(R8),parameter :: F0 = 0.5_R8 + real(R8),parameter :: F1 = 0.15_R8 + real(R8),parameter :: R1 = 10.0_R8 + + real(R8),parameter :: Ricr = 0.30_R8 + real(R8),parameter :: tiny = 1.0e-12_R8 + real(R8),parameter :: tiny2 = 1.0e-6_R8 + real(R8),parameter :: pi = SHR_CONST_PI + + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: i ! iteration loop index + integer(IN) :: lsecs ! local seconds elapsed + integer(IN) :: lonsecs ! incrememnt due to lon offset + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: thvbot ! virtual temperature (K) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: bn ! exchange coef funct for interpolation + real(R8) :: bh ! exchange coef funct for interpolation + real(R8) :: fac ! vertical interpolation factor + real(R8) :: DTiter ! + real(R8) :: DSiter ! + real(R8) :: DViter ! + + real(R8) :: Dcool ! + real(R8) :: Qdel ! net cool skin heating + real(R8) :: Hd ! net heating above -z=d + real(R8) :: Hb ! net kinematic heating above -z = delta + real(R8) :: lambdaV ! + real(R8) :: Fd ! net fresh water forcing above -z=d + real(R8) :: ustarw ! surface wind forcing of layer above -z=d + + real(R8) :: Qsol ! solar heat flux (W/m2) + real(R8) :: Qnsol ! non-solar heat flux (W/m2) + real(R8) :: fsine ! + + real(R8) :: SSS ! sea surface salinity + real(R8) :: alphaT ! + real(R8) :: betaS ! + + real(R8) :: doL ! ocean forcing stablity parameter + real(R8) :: Rid ! Richardson number at depth d + real(R8) :: Ribulk ! Bulk Richardson number at depth d + real(R8) :: FofRi ! Richardon number dependent diffusivity + real(R8) :: Smult ! multiplicative term based on regime + real(R8) :: Sfact ! multiplicative term based on regime + real(R8) :: Kdiff ! diffusive term based on regime + real(R8) :: Kvisc ! viscosity term based on regime + real(R8) :: hsign ! + real(R8) :: rhocn ! + real(R8) :: rcpocn ! + real(R8) :: Nreset ! value for multiplicative reset factor + real(R8) :: resec ! reset offset value in seconds + logical :: lmidnight + logical :: ltwopm + logical :: ltwoam + logical :: lnoon + logical :: lfullday + integer :: nsum + integer :: ier + real(R8) :: pexp ! eqn 19 + real(R8) :: AMP ! eqn 18 + real(R8) :: dif3 + real(R8) :: phid + real(R8) :: spval + + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + real(R8) :: cdn ! function: neutral drag coeff at 10m + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + real(R8) :: molvisc ! molecular viscosity + real(R8) :: molPr ! molecular Prandtl number + + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + molvisc(Tk) = 1.623e-6_R8 * exp((-1.0_R8*(Tk-273.15_R8))/45.2_R8) + molPr(Tk) = 11.64_R8 * exp((-1.0_R8*(Tk-273.15_R8))/40.7_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(shr_flux_atmOcn_diurnal) ' + character(*),parameter :: F00 = "('(shr_flux_atmOcn_diurnal) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: +! computes atm/ocn surface fluxes +! +! NOTES: +! o all fluxes are positive downward +! o net heat flux = net sw + lw up + lw down + sen + lat +! o here, tstar = /U*, and qstar = /U*. +! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) +! +! ASSUMPTIONS: +! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 +! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable +! ctn = .0180 sqrt(cdn), stable +! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) +! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) +!------------------------------------------------------------------------------- + + if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) "enter" + + ! this is especially for flux_diurnal calculations + if (.not. flux_diurnal) then + write(s_logunit,F00) "ERROR: flux_diurnal must be true" + call shr_sys_abort(subName//"flux diurnal must be true") + endif + + spval = shr_const_spval + + al2 = log(zref/ztref) + + if (flux_diurnal) then + ! equations 18 and 19 + AMP = 1.0_R8/F0-1.0_R8 + pexp = log( (1.0_R8/F1-F0) / (1.0_R8-F0) ) / log(R1) + + if (.not. ocn_prognostic) then + ! Set swpen and ocean salinity from following analytic expressions + swpen(:) = 0.67_R8*(exp((-1._R8*shr_const_zsrflyr)/1.0_R8)) + & + 0.33_R8*exp((-1._R8*shr_const_zsrflyr)/17.0_R8) + ocnsal(:) = shr_const_ocn_ref_sal/1000.0_R8 + else + ! use swpen and ocnsal from input argument + endif + +! tcraig, dec 2013, this should only occur on a cold startup. + if (nint(minval(nInc(:))) == 0 .and. & + nint(maxval(nInc(:))) == 0 ) then +! if (s_loglev > 0) then + write(s_logunit,F00) "Initialize diurnal cycle fields" +! end if + warm (:) = 0.0_R8 + salt (:) = 0.0_R8 + speed (:) = 0.0_R8 + regime (:) = 0.0_R8 + qSolAvg (:) = 0.0_R8 + windAvg (:) = 0.0_R8 + warmMax (:) = 0.0_R8 + windMax (:) = 0.0_R8 + warmMaxInc (:) = 0.0_R8 + windMaxInc (:) = 0.0_R8 + qSolInc (:) = 0.0_R8 + windInc (:) = 0.0_R8 + nInc (:) = 0.0_R8 + tSkin_day (:) = ts(:) + tSkin_night(:) = ts(:) + cSkin_night(:) = 0.0_R8 + endif + end if + + DO n=1,nMax + + if (mask(n) /= 0) then + + !--- compute some initial and useful flux quantities --- + + vmag = max(umin, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + alz = log(zbot(n)/zref) + hol = 0.0 + psimh = 0.0 + psixh = 0.0 + rdn = sqrt(cdn(vmag)) + + if (flux_diurnal) then + tBulk(n) = ts(n)+warm(n) ! first guess for tBulk from read in ts,warm + tSkin(n) = tBulk(n) + Qsol = swdn(n) + swup(n) + SSS = 1000.0_R8*ocnsal(n)+salt(n) + lambdaV = lambdaC + + alphaT = 0.000297_R8*(1.0_R8+0.0256_R8*(ts(n)-298.15_R8)+0.003_R8*(SSS - 35.0_R8)) + betaS = 0.000756_R8*(1.0_R8-0.0016_R8*(ts(n)-298.15_R8)) + rhocn = 1023.342_R8*(1.0_R8-0.000297_R8*(ts(n)-298.15_R8)+0.000756_R8 * (SSS - 35.0_R8)) + rcpocn = rhocn * 3990.0_R8*(1.0_R8-0.0012_R8*(SSS - 35.0_R8)) + + Rid = shr_const_g * (alphaT*warm(n) - betaS*salt(n)) *pwr*shr_const_zsrflyr / & + ( pwr*MAX(tiny,speed(n)) )**2 + + Ribulk = 0.0 + + !---------------------------------------------------------- + ! convert elapsed time from GMT to local & + ! check elapsed time. reset warm if near lsecs = reset_sec + !---------------------------------------------------------- + Nreset = 1.0_R8 + resec = Nreset*dt + + lonsecs = ceiling(long(n)/360.0_R8*86400.0) + lsecs = mod(secs + lonsecs,86400) + + lmidnight = (lsecs >= 0 .and. lsecs < dt) ! 0 = midnight + ltwopm = (lsecs >= 48600 .and. lsecs < 48600+dt) ! 48600 = 1:30pm + ltwoam = (lsecs >= 5400 .and. lsecs < 5400 +dt) ! 5400 = 1:30am + lnoon = (lsecs >= 43200 .and. lsecs < 43200+dt) ! 43200 = noon + lfullday = (lsecs > 86400-dt .and. lsecs <= 86400) + nsum = nint(nInc(n)) + + if ( lmidnight ) then + Regime(n) = 1.0_R8 ! RESET DIURNAL + warm(n) = 0.0_R8 + salt(n) = 0.0_R8 + speed(n) = 0.0_R8 + endif + + else ! flux_diurnal + tBulk(n) = ts(n) + tSkin(n) = tBulk(n) + end if + + thvbot = thbot(n) * (1.0_R8 + shr_const_zvir * qbot(n)) ! virtual temp (K) + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + cp = shr_const_cpdair*(1.0_R8 + shr_const_cpvir*ssq) + stable = 0.5_R8 + sign(0.5_R8 , delt) + + + !--- shift wind speed using old coefficient and stability function + + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- initial neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- initial ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + + ! --- iterate --- + + DO i = 1, iMax ! iteration loop + + !------------------------------------------------------------ + ! iterate to converge on FLUXES Z/L, ustar, tstar and qstar + ! and on Rid in the DIURNAL CYCLE + !------------------------------------------------------------ + + if (flux_diurnal) then + + Smult = 0.0_R8 + Sfact = 0.0_R8 + Kdiff = 0.0_R8 + Kvisc = 0.0_R8 + dif3 = 0.0_R8 + + ustarw = ustar*sqrt(rbot(n)/rhocn) + Qnsol = lwdn(n) - shr_const_stebol*(tSkin(n))**4 + & + rbot(n)*ustar*(cp*tstar + shr_const_latvap*qstar) + Hd = (Qnsol + Qsol*(1.0_R8-swpen(n)) ) / rcpocn + Fd = (prec(n) + rbot(n)*ustar*qstar ) * SSS / rhocn + + !--- COOL SKIN EFFECT --- + Dcool = lambdaV*molvisc(tBulk(n)) / ustarw + Qdel = Qnsol + Qsol * & + (0.137_R8 + 11.0_R8*Dcool - 6.6e-5/Dcool *(1.0_R8 - exp((-1.0_R8*Dcool)/8.0e-4))) + Hb = (Qdel/rcpocn)+(Fd*betaS/alphaT) + lambdaV = lambdaC*(1.0_R8 + ( (0.0_R8-Hb)*16.0_R8*molvisc(tBulk(n))* & + shr_const_g*alphaT*molPr(tBulk(n))**2/ustarw**4)**0.75)**(-1/3) + cSkin(n) = MIN(0.0_R8, lambdaV * molPr(tBulk(n)) * Qdel / ustarw / rcpocn ) + + !--- REGIME --- + doL = shr_const_zsrflyr*shr_const_karman*shr_const_g* & + (alphaT*Hd + betaS*Fd ) / ustarw**3 + Rid = MAX(0.0_R8,Rid) + Smult = dt * (pwr+1.0_R8) / (shr_const_zsrflyr*pwr) + Sfact = dt * (pwr+1.0_R8) / (shr_const_zsrflyr)**2 + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + + if ( (doL.gt.0.0_R8) .and. (Qsol.gt.0.0) ) then + phid = MIN(1.0_R8 + 5.0_R8 * doL, 5.0_R8 + doL) + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + dif3 = (kappa0 + NUzero *FofRi) + + if ((doL.le.lambdaL).and.(NINT(regime(n)).le.2)) then + regime(n) = 2.0_R8 + Kdiff = shr_const_karman * ustarw * shr_const_zsrflyr / phid + Kvisc = Kdiff * (1.0_R8 - doL/lambdaL)**2 + & + dif3 * (doL/lambdaL)**2 * (3.0_R8 - 2.0_R8 * doL/lambdaL) + Kdiff = Kvisc + else + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + endif + else + if (regime(n).eq.1.0_R8) then + Smult = 0.0_R8 + else + if (Ribulk .gt. Ricr) then + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + else + regime(n) = 4.0_R8 + Kdiff = shr_const_karman*ustarw*shr_const_zsrflyr *(1.0_R8-7.0_R8*doL)**(1/3) + Kvisc = Kdiff + endif + endif + + endif + + !--- IMPLICIT INTEGRATION --- + + DTiter = (warm(n) +(Smult*Hd)) /(1.+ Sfact*Kdiff) + DSiter = (salt(n) -(Smult*Fd)) /(1.+ Sfact*Kdiff) + DViter = (speed(n) +(Smult*ustarw*ustarw)) /(1.+ Sfact*Kvisc) + DTiter = MAX( 0.0_R8, DTiter) + DViter = MAX( 0.0_R8, DViter) + + Rid =(shr_const_g*(alphaT*DTiter-betaS*DSiter)*pwr*shr_const_zsrflyr) / & + (pwr*MAX(tiny,DViter))**2 + Ribulk = Rid * pwr + Ribulk = 0.0_R8 + tBulk(n) = ts(n) + DTiter + tSkin(n) = tBulk(n) + cskin(n) + + !--need to update ssq,delt,delq as function of tBulk ---- + + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + + else ! not flux_diurnal + + !--- if control case, regime should be 0 + regime(n) = 0.0_R8 + Smult = 0.0_R8 + Kdiff = 0.0_R8 + Kvisc = 0.0_R8 + warm(n) = 0.0_R8 + salt(n) = 0.0_R8 + speed(n) = 0.0_R8 + cSkin(n) = 0.0_R8 + endif + + !--- UPDATE FLUX ITERATION --- + + !--- compute stability & evaluate all stability functions --- + hol = shr_const_karman*shr_const_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/shr_const_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient and stability function --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- update neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/shr_const_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/shr_const_karman*(alz-psixh)) + + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + ENDDO ! end iteration loop + + !--- COMPUTE FLUXES TO ATMOSPHERE AND OCEAN --- + tau = rbot(n) * ustar * ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = cp * tau * tstar / ustar + lat (n) = shr_const_latvap * tau * qstar / ustar + lwup(n) = -shr_const_stebol * Tskin(n)**4 + + !--- water flux --- + evap(n) = lat(n)/shr_const_latvap + + !------------------------------------------------------------ + ! compute diagnostics: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/shr_const_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/shr_const_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + if (flux_diurnal) then + + !------------------------------------------------------------ + ! update new prognostic variables + !------------------------------------------------------------ + + warm (n) = DTiter + salt (n) = DSiter + speed (n) = DViter + + if (ltwopm) then + tSkin_day(n) = tSkin(n) + warmmax(n) = max(DTiter,0.0_R8) + endif + + if (ltwoam) then + tSkin_night(n) = tSkin(n) + cSkin_night(n) = cSkin(n) + endif + + if ((lmidnight).and.(lfullday)) then + qSolAvg(n) = qSolInc(n)/real(nsum+1,R8) + windAvg(n) = windInc(n)/real(nsum+1,R8) + ! warmMax(n) = max(DTiter,warmMaxInc(n)) + windMax(n) = max(u10n,windMaxInc(n)) + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + +! tSkin_night(n) = tSkin(n) +! cSkin_night(n) = cSkin(n) + + else + + if ((lmidnight).and.(.not.(lfullday))) then + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + + else + + nsum = nsum + 1 + + ! warmMaxInc (n) = max(DTiter,warmMaxInc(n)) + windMaxInc (n) = max(u10n, windMaxInc(n)) + ! windMaxInc (n) = max(Qsol, windMaxInc(n)) + qSolInc (n) = qSolInc(n)+Qsol + windInc (n) = windInc(n)+u10n + + endif + endif + + nInc(n) = real(nsum,R8) ! set nInc to incremented or reset nsum + + + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv (n) = re + if (present(ssq_sv )) ssq_sv (n) = ssq + + else ! mask = 0 + + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + warm (n) = spval ! NEW + salt (n) = spval ! NEW + speed (n) = spval ! NEW + regime (n) = spval ! NEW + tBulk (n) = spval ! NEW + tSkin (n) = spval ! NEW + tSkin_night(n) = spval ! NEW + tSkin_day (n) = spval ! NEW + cSkin (n) = spval ! NEW + cSkin_night(n) = spval ! NEW + warmMax (n) = spval ! NEW + windMax (n) = spval ! NEW + qSolAvg (n) = spval ! NEW + windAvg (n) = spval ! NEW + warmMaxInc (n) = spval ! NEW + windMaxInc (n) = spval ! NEW + qSolInc (n) = spval ! NEW + windInc (n) = spval ! NEW + nInc (n) = 0.0_R8 ! NEW + + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + + endif ! mask + + endif ! flux diurnal logic + + ENDDO ! end n loop + +END subroutine shr_flux_atmOcn_diurnal + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_flux_atmIce -- computes atm/ice fluxes +! +! !DESCRIPTION: +! Computes atm/ice fluxes +! +! !REVISION HISTORY: +! 2006-Jun-12 - B. Kauffman, first version, adapted from dice6 code +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_flux_atmIce(mask ,zbot ,ubot ,vbot ,thbot & + & ,qbot ,rbot ,tbot ,ts ,sen & + & ,lat ,lwup ,evap ,taux ,tauy & + & ,tref ,qref ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer(IN),intent(in) :: mask (:) ! 0 <=> cell NOT in model domain + real(R8) ,intent(in) :: zbot (:) ! atm level height (m) + real(R8) ,intent(in) :: ubot (:) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (:) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(:) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (:) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: rbot (:) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (:) ! atm T (K) + real(R8) ,intent(in) :: ts (:) ! surface temperature + + !--- output arguments ------------------------------- + real(R8) ,intent(out) :: sen (:) ! sensible heat flux (W/m^2) + real(R8) ,intent(out) :: lat (:) ! latent heat flux (W/m^2) + real(R8) ,intent(out) :: lwup (:) ! long-wave upward heat flux (W/m^2) + real(R8) ,intent(out) :: evap (:) ! evaporative water flux ((kg/s)/m^2) + real(R8) ,intent(out) :: taux (:) ! x surface stress (N) + real(R8) ,intent(out) :: tauy (:) ! y surface stress (N) + real(R8) ,intent(out) :: tref (:) ! 2m reference height temperature + real(R8) ,intent(out) :: qref (:) ! 2m reference height humidity + +!EOP + + !--- local constants -------------------------------- + real(R8),parameter :: umin = 1.0_R8 ! minimum wind speed (m/s) + real(R8),parameter :: zref = 10.0_R8 ! ref height ~ m + real(R8),parameter :: ztref = 2.0_R8 ! ref height for air T ~ m + real(R8),parameter :: spval = shr_const_spval ! special value + real(R8),parameter :: zzsice = 0.0005_R8 ! ice surface roughness + + !--- local variables -------------------------------- + integer(IN) :: lsize ! array dimensions + integer(IN) :: n ! array indicies + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: thvbot ! virtual temperature (K) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: dssqdt ! derivative of ssq wrt Ts (kg/kg/K) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coefficient (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coefficient (heat) + real(R8) :: ren ! sqrt of neutral exchange coefficient (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! temporary variable + real(R8) :: xqq ! temporary variable + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: alz ! ln(zbot/z10) + real(R8) :: ltheat ! latent heat for surface + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + + real(R8) :: bn ! exchange coef funct for interpolation + real(R8) :: bh ! exchange coef funct for interpolation + real(R8) :: fac ! interpolation factor + real(R8) :: ln0 ! log factor for interpolation + real(R8) :: ln3 ! log factor for interpolation + + !--- local functions -------------------------------- + real(R8) :: Tk ! temperature (K) + real(R8) :: qsat ! the saturation humidity of air (kg/m^3) + real(R8) :: dqsatdt ! derivative of qsat wrt surface temperature + real(R8) :: xd ! dummy argument + real(R8) :: psimhu ! unstable part of psimh + real(R8) :: psixhu ! unstable part of psimx + + qsat(Tk) = 627572.4_R8 / exp(5107.4_R8/Tk) + dqsatdt(Tk) = (5107.4_R8 / Tk**2) * 627572.4_R8 / exp(5107.4_R8/Tk) + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = "(shr_flux_atmIce) " + +!------------------------------------------------------------------------------- +! PURPOSE: +! using atm & ice state variables, compute atm/ice fluxes +! and diagnostic 10m air temperature and humidity +! +! NOTE: +! o all fluxes are positive downward +! o net heat flux = net sw + lw up + lw down + sen + lat +! o here, tstar = /U*, and qstar = /U*. +! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) +! +! ASSUME: +! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) +!------------------------------------------------------------------------------- + + lsize = size(tbot) + + do n = 1,lsize + + if (mask(n) == 0) then + sen (n) = spval + lat (n) = spval + lwup (n) = spval + evap (n) = spval + taux (n) = spval + tauy (n) = spval + tref (n) = spval + qref (n) = spval + else + !--- define some needed variables --- + vmag = max(umin, sqrt(ubot(n)**2+vbot(n)**2)) + thvbot = thbot(n)*(1.0_R8 + loc_zvir * qbot(n)) ! virtual pot temp (K) + ssq = qsat (ts(n)) / rbot(n) ! sea surf hum (kg/kg) + dssqdt = dqsatdt(ts(n)) / rbot(n) ! deriv of ssq wrt Ts + delt = thbot(n) - ts(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + alz = log(zbot(n)/zref) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) + ltheat = loc_latvap + loc_latice + + !---------------------------------------------------------- + ! first estimate of Z/L and ustar, tstar and qstar + !---------------------------------------------------------- + + !--- neutral coefficients, z/L = 0.0 --- + rdn = loc_karman/log(zref/zzsice) + rhn = rdn + ren = rdn + + !--- ustar,tstar,qstar ---- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + + !--- compute stability & evaluate all stability functions --- + hol = loc_karman * loc_g * zbot(n) & + & * (tstar/thvbot+qstar/(1.0_R8/loc_zvir+qbot(n))) / ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8+rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8+rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8+ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar w/ updated, shifted coeffs -- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !---------------------------------------------------------- + ! iterate to converge on Z/L, ustar, tstar and qstar + !---------------------------------------------------------- + + !--- compute stability & evaluate all stability functions --- + hol = loc_karman * loc_g * zbot(n) & + & * (tstar/thvbot+qstar/(1.0_R8/loc_zvir+qbot(n))) / ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8+rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8+rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8+ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar w/ updated, shifted coeffs -- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !---------------------------------------------------------- + ! compute the fluxes + !---------------------------------------------------------- + + tau = rbot(n) * ustar * ustar + + !--- momentum flux --- + taux(n) = tau * ubot(n) / vmag + tauy(n) = tau * vbot(n) / vmag + + !--- heat flux --- + sen (n) = cp * tau * tstar / ustar + lat (n) = ltheat * tau * qstar / ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/ltheat + + !---------------------------------------------------------- + ! compute diagnostic: 2m reference height temperature + !---------------------------------------------------------- + + !--- Compute function of exchange coefficients. Assume that + !--- cn = rdn*rdn, cm=rd*rd and ch=rh*rd, and therefore + !--- 1/sqrt(cn(n))=1/rdn and sqrt(cm(n))/ch(n)=1/rh + bn = loc_karman/rdn + bh = loc_karman/rh + + !--- Interpolation factor for stable and unstable cases + ln0 = log(1.0_R8 + (ztref/zbot(n))*(exp(bn) - 1.0_R8)) + ln3 = log(1.0_R8 + (ztref/zbot(n))*(exp(bn - bh) - 1.0_R8)) + fac = (ln0 - ztref/zbot(n)*(bn - bh))/bh * stable & + & + (ln0 - ln3)/bh * (1.0_R8-stable) + fac = min(max(fac,0.0_R8),1.0_R8) + + !--- actual interpolation + tref(n) = ts(n) + (tbot(n) - ts(n))*fac + qref(n) = qbot(n) - delq*fac + + endif + enddo + +end subroutine shr_flux_atmIce + +!=============================================================================== +! !BOP ========================================================================= +! +! !IROUTINE: shr_flux_MOstability -- Monin-Obukhov BL stability functions +! +! !DESCRIPTION: +! +! Monin-Obukhov boundary layer stability functions, two options: +! turbulent velocity scales or gradient and integral functions +! via option = shr_flux_MOwScales or shr_flux_MOfunctions +! +! !REVISION HISTORY: +! 2007-Sep-19 - B. Kauffman, Bill Large - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_flux_MOstability(option,arg1,arg2,arg3,arg4,arg5) + +! !USES: + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(IN),intent(in) :: option ! shr_flux_MOwScales or MOfunctions + real(R8) ,intent(in) :: arg1 ! scales: uStar (in) funct: zeta (in) + real(R8) ,intent(inout) :: arg2 ! scales: zkB (in) funct: phim (out) + real(R8) ,intent(out) :: arg3 ! scales: phim (out) funct: phis (out) + real(R8) ,intent(out) :: arg4 ! scales: phis (out) funct: psim (out) + real(R8) ,intent(out),optional :: arg5 ! scales: (unused) funct: psis (out) + +! !EOP + + !----- local variables ----- + real(R8) :: zeta ! z/L + real(R8) :: uStar ! friction velocity + real(R8) :: zkB ! (height)*(von Karman)*(surface bouyancy flux) + real(R8) :: phim ! momentum gradient function or scale + real(R8) :: phis ! temperature gradient function or scale + real(R8) :: psim ! momentum integral function or scale + real(R8) :: psis ! temperature integral function or scale + real(R8) :: temp ! temporary-variable/partial calculation + + !----- local variables, stable case ----- + real(R8),parameter :: uStarMin = 0.001_R8 ! lower bound on uStar + real(R8),parameter :: a = 1.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: b = 0.667_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: c = 5.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: d = 0.350_R8 ! constant from Holtslag & de Bruin, equation 12 + + !----- local variables, unstable case ----- + real(R8),parameter :: a2 = 3.0_R8 ! constant from Wilson, equation 10 + + !----- formats ----- + character(*),parameter :: subName = '(shr_flux_MOstability) ' + character(*),parameter :: F00 = "('(shr_flux_MOstability) ',4a)" + character(*),parameter :: F01 = "('(shr_flux_MOstability) ',a,i5)" + +!------------------------------------------------------------------------------- +! Notes:: +! o this could be two routines, but are one to help keep them aligned +! o the stable calculation is taken from... +! A.A.M. HoltSlag and H.A.R. de Bruin, 1988: +! "Applied Modeling of the Nighttime Surface Energy Balance over Land", +! Journal of Applied Meteorology, Vol. 27, No. 6, June 1988, 659-704 +! o the unstable calculation is taken from... +! D. Keith Wilson, 2001: "An Alternative Function for the Wind and +! Temperature Gradients in Unstable Surface Layers", +! Boundary-Layer Meteorology, 99 (2001), 151-158 +!------------------------------------------------------------------------------- + + !----- check for consistancy between option and arguments ------------------ + if (debug > 1 .and. s_loglev > 0) then + if (debug > 2) write(s_logunit,F01) "enter, option = ",option + if ( option == shr_flux_MOwScales .and. present(arg5) ) then + write(s_logunit,F01) "ERROR: option1 must have four arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else if ( option == shr_flux_MOfunctions .and. .not. present(arg5) ) then + write(s_logunit,F01) "ERROR: option2 must have five arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else + write(s_logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + end if + end if + + !------ velocity scales option ---------------------------------------------- + if (option == shr_flux_MOwScales) then + + !--- input --- + uStar = arg1 + zkB = arg2 + + if (zkB >= 0.0_R8) then ! ----- stable ----- + zeta = zkB/(max(uStar,uStarMin)**3) + temp = exp(-d*zeta) + phim = uStar/(1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp)) + phis = phim + else ! ----- unstable ----- + temp = (zkB*zkB)**(1.0_R8/a2) ! note: zkB < 0, zkB*zkB > 0 + phim = sqrt(uStar**2 + shr_flux_MOgammaM*temp) + phis = sqrt(uStar**2 + shr_flux_MOgammaS*temp) + end if + + !--- output --- + arg3 = phim + arg4 = phis + ! arg5 = + + !------ stability function option ------------------------------------------- + else if (option == shr_flux_MOfunctions) then + + !--- input --- + zeta = arg1 + + if (zeta >= 0.0_R8) then ! ----- stable ----- + temp = exp(-d*zeta) + phim = 1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp) + phis = phim + psim = -a*zeta - b*(zeta - c/d)*temp - b*c/d + psis = psim + else ! ----- unstable ---- + temp = (zeta*zeta)**(1.0_R8/a2) ! note: zeta < 0, zeta*zeta > 0 + phim = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaM*temp) + phis = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaS*temp) + psim = a2*log(0.5_R8 + 0.5_R8/phim) + psis = a2*log(0.5_R8 + 0.5_R8/phis) + end if + + !--- output --- + arg2 = phim + arg3 = phis + arg4 = psim + arg5 = psis + !---------------------------------------------------------------------------- + else + write(s_logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + endif + +end subroutine shr_flux_MOstability + +!=============================================================================== +!=============================================================================== + +end module shr_flux_mod diff --git a/share/csm_share/shr/shr_infnan_mod.F90.in b/share/csm_share/shr/shr_infnan_mod.F90.in new file mode 100644 index 000000000000..74f37ba4ea3e --- /dev/null +++ b/share/csm_share/shr/shr_infnan_mod.F90.in @@ -0,0 +1,407 @@ + +! Flag representing compiler support of Fortran 2003's +! ieee_arithmetic intrinsic module. +#if defined CPRIBM || defined CPRPGI || defined CPRINTEL || defined CPRCRAY || defined CPRNAG +#define HAVE_IEEE_ARITHMETIC +#endif + +module shr_infnan_mod +!--------------------------------------------------------------------- +! Module to test for IEEE Inf and NaN values, which also provides a +! method of setting +/-Inf and signaling or quiet NaN. +! +! All functions are elemental, and thus work on arrays. +!--------------------------------------------------------------------- +! To test for these values, just call the corresponding function, e.g: +! +! var_is_nan = shr_infnan_isnan(x) +! +! You can also use it on arrays: +! +! array_contains_nan = any(shr_infnan_isnan(my_array)) +! +!--------------------------------------------------------------------- +! To generate these values, assign one of the provided derived-type +! variables to a real: +! +! use shr_infnan_mod, only: nan => shr_infnan_nan, & +! inf => shr_infnan_inf, & +! assignment(=) +! real(r4) :: my_nan +! real(r8) :: my_inf_array(2,2) +! my_nan = nan +! my_inf_array = inf +! +! Keep in mind that "shr_infnan_nan" and "shr_infnan_inf" cannot be +! passed to functions that expect real arguments. To pass a real +! NaN, you will have to use shr_infnan_nan to set a local real of +! the correct kind. +!--------------------------------------------------------------------- + +use shr_kind_mod, only: & + r4 => SHR_KIND_R4, & + r8 => SHR_KIND_R8 + +#ifdef HAVE_IEEE_ARITHMETIC + +! If we have IEEE_ARITHMETIC, the NaN test is provided for us. +use, intrinsic :: ieee_arithmetic, only: & + shr_infnan_isnan => ieee_is_nan + +#else + +! Integers of correct size for bit patterns below. +use shr_kind_mod, only: i4 => shr_kind_i4, i8 => shr_kind_i8 + +#endif + +implicit none +private +save + +! Test functions for NaN/Inf values. +public :: shr_infnan_isnan +public :: shr_infnan_isinf +public :: shr_infnan_isposinf +public :: shr_infnan_isneginf + +! Locally defined isnan. +#ifndef HAVE_IEEE_ARITHMETIC +interface shr_infnan_isnan + ! TYPE double,real + module procedure shr_infnan_isnan_{TYPE} +end interface +#endif + +interface shr_infnan_isinf + ! TYPE double,real + module procedure shr_infnan_isinf_{TYPE} +end interface + +interface shr_infnan_isposinf + ! TYPE double,real + module procedure shr_infnan_isposinf_{TYPE} +end interface + +interface shr_infnan_isneginf + ! TYPE double,real + module procedure shr_infnan_isneginf_{TYPE} +end interface + +! Derived types for generation of NaN/Inf +! Even though there's no reason to "use" the types directly, some compilers +! might have trouble with an object being used without its type. +public :: shr_infnan_nan_type +public :: shr_infnan_inf_type +public :: assignment(=) +public :: shr_infnan_to_r4 +public :: shr_infnan_to_r8 + +! Type representing Not A Number. +type :: shr_infnan_nan_type + logical :: quiet = .false. +end type shr_infnan_nan_type + +! Type representing +/-Infinity. +type :: shr_infnan_inf_type + logical :: positive = .true. +end type shr_infnan_inf_type + +! Allow assigning reals to NaN or Inf. +interface assignment(=) + ! TYPE double,real + ! DIMS 0,1,2,3,4,5,6,7 + module procedure set_nan_{DIMS}d_{TYPE} + ! TYPE double,real + ! DIMS 0,1,2,3,4,5,6,7 + module procedure set_inf_{DIMS}d_{TYPE} +end interface + +! Conversion functions. +interface shr_infnan_to_r8 + module procedure nan_r8 + module procedure inf_r8 +end interface + +interface shr_infnan_to_r4 + module procedure nan_r4 + module procedure inf_r4 +end interface + +! Initialize objects of NaN/Inf type for other modules to use. + +! Default NaN is signaling, but also provide snan and qnan to choose +! explicitly. +type(shr_infnan_nan_type), public, parameter :: shr_infnan_nan = & + shr_infnan_nan_type(.false.) +type(shr_infnan_nan_type), public, parameter :: shr_infnan_snan = & + shr_infnan_nan_type(.false.) +type(shr_infnan_nan_type), public, parameter :: shr_infnan_qnan = & + shr_infnan_nan_type(.true.) + +! Default Inf is positive, but provide posinf to go with neginf. +type(shr_infnan_inf_type), public, parameter :: shr_infnan_inf = & + shr_infnan_inf_type(.true.) +type(shr_infnan_inf_type), public, parameter :: shr_infnan_posinf = & + shr_infnan_inf_type(.true.) +type(shr_infnan_inf_type), public, parameter :: shr_infnan_neginf = & + shr_infnan_inf_type(.false.) + +! Bit patterns for implementation without ieee_arithmetic. +! Note that in order to satisfy gfortran's range check, we have to use +! ibset to set the sign bit from a BOZ pattern. +#ifndef HAVE_IEEE_ARITHMETIC +! Single precision. +integer(i4), parameter :: ssnan_pat = int(Z'7FA00000',i4) +integer(i4), parameter :: sqnan_pat = int(Z'7FC00000',i4) +integer(i4), parameter :: sposinf_pat = int(Z'7F800000',i4) +integer(i4), parameter :: sneginf_pat = ibset(sposinf_pat,bit_size(1_i4)-1) +! Double precision. +integer(i8), parameter :: dsnan_pat = int(Z'7FF4000000000000',i8) +integer(i8), parameter :: dqnan_pat = int(Z'7FF8000000000000',i8) +integer(i8), parameter :: dposinf_pat = int(Z'7FF0000000000000',i8) +integer(i8), parameter :: dneginf_pat = ibset(dposinf_pat,bit_size(1_i8)-1) +#endif + +contains + +!--------------------------------------------------------------------- +! TEST FUNCTIONS +!--------------------------------------------------------------------- +! The "isinf" function simply calls "isposinf" and "isneginf". +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isinf_{TYPE}(x) result(isinf) + {VTYPE}, intent(in) :: x + logical :: isinf + + isinf = shr_infnan_isposinf(x) .or. shr_infnan_isneginf(x) + +end function shr_infnan_isinf_{TYPE} + +#ifdef HAVE_IEEE_ARITHMETIC + +!--------------------------------------------------------------------- +! The "isposinf" and "isneginf" functions get the IEEE class of a +! real, and test to see if the class is equal to ieee_positive_inf +! or ieee_negative_inf. +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isposinf_{TYPE}(x) result(isposinf) + use, intrinsic :: ieee_arithmetic, only: & + ieee_class, & + ieee_positive_inf, & + operator(==) + {VTYPE}, intent(in) :: x + logical :: isposinf + + isposinf = (ieee_positive_inf == ieee_class(x)) + +end function shr_infnan_isposinf_{TYPE} + +! TYPE double,real +elemental function shr_infnan_isneginf_{TYPE}(x) result(isneginf) + use, intrinsic :: ieee_arithmetic, only: & + ieee_class, & + ieee_negative_inf, & + operator(==) + {VTYPE}, intent(in) :: x + logical :: isneginf + + isneginf = (ieee_negative_inf == ieee_class(x)) + +end function shr_infnan_isneginf_{TYPE} + +#else +! Don't have ieee_arithmetic. + +#ifdef CPRGNU +! NaN testing on gfortran. +! TYPE double,real +elemental function shr_infnan_isnan_{TYPE}(x) result(is_nan) + {VTYPE}, intent(in) :: x + logical :: is_nan + + is_nan = isnan(x) + +end function shr_infnan_isnan_{TYPE} +! End GNU section. +#endif + +!--------------------------------------------------------------------- +! The "isposinf" and "isneginf" functions just test against a known +! bit pattern if we don't have ieee_arithmetic. +!--------------------------------------------------------------------- + +! TYPE double,real +elemental function shr_infnan_isposinf_{TYPE}(x) result(isposinf) + {VTYPE}, intent(in) :: x + logical :: isposinf +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: posinf_pat = sposinf_pat +#else + integer(i8), parameter :: posinf_pat = dposinf_pat +#endif + + isposinf = (x == transfer(posinf_pat,x)) + +end function shr_infnan_isposinf_{TYPE} + +! TYPE double,real +elemental function shr_infnan_isneginf_{TYPE}(x) result(isneginf) + {VTYPE}, intent(in) :: x + logical :: isneginf +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: neginf_pat = sneginf_pat +#else + integer(i8), parameter :: neginf_pat = dneginf_pat +#endif + + isneginf = (x == transfer(neginf_pat,x)) + +end function shr_infnan_isneginf_{TYPE} + +! End ieee_arithmetic conditional. +#endif + +!--------------------------------------------------------------------- +! GENERATION FUNCTIONS +!--------------------------------------------------------------------- +! Two approaches for generation of NaN and Inf values: +! 1. With Fortran 2003, use the ieee_value intrinsic to get a value +! from the corresponding class. These are: +! - ieee_signaling_nan +! - ieee_quiet_nan +! - ieee_positive_inf +! - ieee_negative_inf +! 2. Without Fortran 2003, set the IEEE bit patterns directly. +! Use BOZ literals to get an integer with the correct bit +! pattern, then use "transfer" to transfer those bits into a +! real. +!--------------------------------------------------------------------- + +! TYPE double,real +! DIMS 0,1,2,3,4,5,6,7 +pure subroutine set_nan_{DIMS}d_{TYPE}(output, nan) +#ifdef HAVE_IEEE_ARITHMETIC + use, intrinsic :: ieee_arithmetic, only: & + ieee_signaling_nan, & + ieee_quiet_nan, & + ieee_value +#else +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: snan_pat = ssnan_pat + integer(i4), parameter :: qnan_pat = sqnan_pat +#else + integer(i8), parameter :: snan_pat = dsnan_pat + integer(i8), parameter :: qnan_pat = dqnan_pat +#endif +#endif + {VTYPE}, intent(out) :: output{DIMSTR} + type(shr_infnan_nan_type), intent(in) :: nan + + ! Use scalar temporary for performance reasons, to reduce the cost of + ! the ieee_value call. + {VTYPE} :: tmp + +#ifdef HAVE_IEEE_ARITHMETIC + if (nan%quiet) then + tmp = ieee_value(tmp, ieee_quiet_nan) + else + tmp = ieee_value(tmp, ieee_signaling_nan) + end if +#else + if (nan%quiet) then + tmp = transfer(qnan_pat, tmp) + else + tmp = transfer(snan_pat, tmp) + end if +#endif + + output = tmp + +end subroutine set_nan_{DIMS}d_{TYPE} + +! TYPE double,real +! DIMS 0,1,2,3,4,5,6,7 +pure subroutine set_inf_{DIMS}d_{TYPE}(output, inf) +#ifdef HAVE_IEEE_ARITHMETIC + use, intrinsic :: ieee_arithmetic, only: & + ieee_positive_inf, & + ieee_negative_inf, & + ieee_value +#else +#if ({ITYPE} == TYPEREAL) + integer(i4), parameter :: posinf_pat = sposinf_pat + integer(i4), parameter :: neginf_pat = sneginf_pat +#else + integer(i8), parameter :: posinf_pat = dposinf_pat + integer(i8), parameter :: neginf_pat = dneginf_pat +#endif +#endif + {VTYPE}, intent(out) :: output{DIMSTR} + type(shr_infnan_inf_type), intent(in) :: inf + + ! Use scalar temporary for performance reasons, to reduce the cost of + ! the ieee_value call. + {VTYPE} :: tmp + +#ifdef HAVE_IEEE_ARITHMETIC + if (inf%positive) then + tmp = ieee_value(tmp,ieee_positive_inf) + else + tmp = ieee_value(tmp,ieee_negative_inf) + end if +#else + if (inf%positive) then + tmp = transfer(posinf_pat, tmp) + else + tmp = transfer(neginf_pat, tmp) + end if +#endif + + output = tmp + +end subroutine set_inf_{DIMS}d_{TYPE} + +!--------------------------------------------------------------------- +! CONVERSION INTERFACES. +!--------------------------------------------------------------------- +! Function methods to get reals from nan/inf types. +!--------------------------------------------------------------------- + +pure function nan_r8(nan) result(output) + class(shr_infnan_nan_type), intent(in) :: nan + real(r8) :: output + + output = nan + +end function nan_r8 + +pure function nan_r4(nan) result(output) + class(shr_infnan_nan_type), intent(in) :: nan + real(r4) :: output + + output = nan + +end function nan_r4 + +pure function inf_r8(inf) result(output) + class(shr_infnan_inf_type), intent(in) :: inf + real(r8) :: output + + output = inf + +end function inf_r8 + +pure function inf_r4(inf) result(output) + class(shr_infnan_inf_type), intent(in) :: inf + real(r4) :: output + + output = inf + +end function inf_r4 + +end module shr_infnan_mod diff --git a/share/csm_share/shr/shr_kind_mod.F90 b/share/csm_share/shr/shr_kind_mod.F90 new file mode 100644 index 000000000000..cd4e8085393d --- /dev/null +++ b/share/csm_share/shr/shr_kind_mod.F90 @@ -0,0 +1,24 @@ +!=============================================================================== +! SVN $Id: shr_kind_mod.F90 65994 2014-12-03 22:44:59Z cacraig@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_kind_mod.F90 $ +!=============================================================================== + +MODULE shr_kind_mod + + !---------------------------------------------------------------------------- + ! precision/kind constants add data public + !---------------------------------------------------------------------------- + public + integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real + integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real + integer,parameter :: SHR_KIND_RN = kind(1.0) ! native real + integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer + integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer + integer,parameter :: SHR_KIND_IN = kind(1) ! native integer + integer,parameter :: SHR_KIND_CS = 80 ! short char + integer,parameter :: SHR_KIND_CM = 160 ! mid-sized char + integer,parameter :: SHR_KIND_CL = 256 ! long char + integer,parameter :: SHR_KIND_CX = 512 ! extra-long char + integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char + +END MODULE shr_kind_mod diff --git a/share/csm_share/shr/shr_log_mod.F90 b/share/csm_share/shr/shr_log_mod.F90 new file mode 100644 index 000000000000..eeb7a3c127ca --- /dev/null +++ b/share/csm_share/shr/shr_log_mod.F90 @@ -0,0 +1,99 @@ +!BOP =========================================================================== +! +! !MODULE: shr_log_mod -- variables and methods for logging +! +! !DESCRIPTION: +! Low-level shared variables for logging. +! +! Also, routines for generating log file messages. +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_log_mod + +! !USES: + + use shr_kind_mod + use shr_strconvert_mod, only: toString + + use shr_strconvert_mod, only: toString + + use, intrinsic :: iso_fortran_env, only: output_unit + + implicit none + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_log_errMsg + public :: shr_log_OOBMsg + +! !PUBLIC DATA MEMBERS: + + public :: shr_log_Level + public :: shr_log_Unit + +!EOP + + ! low-level shared variables for logging, these may not be parameters + integer(SHR_KIND_IN) :: shr_log_Level = 1 + integer(SHR_KIND_IN) :: shr_log_Unit = output_unit + +contains + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_log_errMsg -- Return an error message containing file & line info +! +! !DESCRIPTION: +! Return an error message containing file & line info +! \newline +! errMsg = shr\_log\_errMsg(__FILE__, __LINE__) +! +! !REVISION HISTORY: +! 2013-July-23 - Bill Sacks +! +! !INTERFACE: ------------------------------------------------------------------ + +pure function shr_log_errMsg(file, line) + +! !INPUT/OUTPUT PARAMETERS: + + character(len=SHR_KIND_CX) :: shr_log_errMsg + character(len=*), intent(in) :: file + integer , intent(in) :: line + +!EOP + + shr_log_errMsg = 'ERROR in '//trim(file)//' at line '//toString(line) + +end function shr_log_errMsg + +! Create a message for an out of bounds error. +pure function shr_log_OOBMsg(operation, bounds, idx) result(OOBMsg) + + ! A name for the operation being attempted when the bounds error + ! occurred. A string containing the subroutine name is ideal, but more + ! generic descriptions such as "read", "modify", or "insert" could be used. + character(len=*), intent(in) :: operation + + ! Upper and lower bounds allowed for the operation. + integer, intent(in) :: bounds(2) + + ! Index at which access was attempted. + integer, intent(in) :: idx + + ! Output message + character(len=:), allocatable :: OOBMsg + + allocate(OOBMsg, source=(operation//": "//toString(idx)//" not in range ["//& + toString(bounds(1))//", "//toString(bounds(2))//"].")) + +end function shr_log_OOBMsg + +end module shr_log_mod diff --git a/share/csm_share/shr/shr_map_mod.F90 b/share/csm_share/shr/shr_map_mod.F90 new file mode 100644 index 000000000000..7c8d3675748f --- /dev/null +++ b/share/csm_share/shr/shr_map_mod.F90 @@ -0,0 +1,3432 @@ +!=============================================================================== +! SVN $Id: shr_map_mod.F90 35318 2012-03-08 23:40:50Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_map_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_map_mod -- generic map data type and associated methods +! +! !DESCRIPTION: +! Generic map data type and associated methods +! \newline +! This module supports mapping of fields from one grid to another. +! A general datatype, shr\_map\_mapType, stores the mapping information +! set in shr\_map\_mapSet. shr\_map\_mapData then allows this mapping +! to be applied to an input array to generate the output array. +! \newline +! The mapType has several flags that give the user various options +! for setting the mapping +! type: [remap,fill] +! remap - mapping of data between different grids, primarily +! for the active grid area +! fill - mapping of data on the same grid, primarily to fill missing +! areas, copy data, or set the array to a spval. +! algo: [copy,bilinear,nn,nnoni,nnonj,spval] +! copy - copy data from one array to another using indexing +! bilinear - bilinear remapping using 4 corner points +! nn - nearest neighbor, set value to nn value +! nnoni - nearest neighbor using i, search for nearest neighbor in the +! i direction first, then j +! nnonj - nearest neighbor using j, search for nearest neighbor in the +! j direction first, then i +! spval - set values to the spval +! mask: [srcmask,dstmask,nomask,bothmask] +! srcmask - use only src points with mask = true in mapping +! dstmask - map only to dst points where mask = true +! nomask - ignore both src and dst mask in mapping +! bothmask - use both src and dst mask in mapping (srcmask and dstmask) +! vect: [scalar,vector] +! scalar - fields are scalar type (default) +! vector - fields are vector type, operates only on 2 fields to 2 fields +! NOTE: Not all combinatations are unique and not all combinations are valid +! \newline +! The above settings are put into the maptype using shr\_map\_put. Public +! parameters are available to users to set the switches. The first three +! switches must be set then the mapSet method can be called. After the +! mapSet method is called, the mapData method can be used. +! \newline +! A Note on Subroutine Arguments: +! Lat, lon, and mask arguments in these routines are 2d (nx,ny) +! Array arguments are 2d (nf,nxy), number of fields by grid point +! \newline +! General Usage: +! type(shr\_map\_mapType) :: mymap +! call shr\_map\_put(mymap,'type','remap') +! call shr\_map\_put(mymap,shr\_map\_fs\_algo,shr\_map\_fs\_bilinear) +! call shr\_map\_put(mymap,shr\_map\_fs\_mask,'bothmask') +! call shr\_map\_put(mymap,shr\_map\_fs\_vect,'scalar') +! call shr\_map\_mapSet(mymap,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,rc=rCode) +! call shr\_map\_mapData(Asrc,Adst,mymap) +! \newline +! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,name='fillnnoni',type='fill',algo='nnoni',mask='dstmask',rc=rc) +! call shr\_map\_mapData(Asrc,Adst,mymap) +! \newline +! call shr\_map\_mapData(Ain,Aout,Xs,Ys,Ms,Xd,Yd,Md,type='remap',algo='nn',mask='dstmask',rc) +! +! !REMARKS: +! nn needs a faster algorithm +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_map_mod + +! !USES: + + use shr_const_mod + use shr_kind_mod + use shr_sys_mod + use shr_timer_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + private + +! !PUBLIC TYPES: + + public :: shr_map_maptype ! shr_map datatype + + type shr_map_mapType ! like mct sparsematrix datatype + private + character(SHR_KIND_CS) :: name + character(SHR_KIND_CS) :: type + character(SHR_KIND_CS) :: algo + character(SHR_KIND_CS) :: mask + character(SHR_KIND_CS) :: vect + integer(SHR_KIND_IN) :: nsrc ! grid size or src + integer(SHR_KIND_IN) :: ndst ! grid size of dst + integer(SHR_KIND_IN) :: nwts ! number of total weights + real(SHR_KIND_R8) ,pointer :: xsrc(:) ! longitude, for vector, rad + real(SHR_KIND_R8) ,pointer :: ysrc(:) ! latitude , for vector, rad + real(SHR_KIND_R8) ,pointer :: xdst(:) ! longitude, for vector, rad + real(SHR_KIND_R8) ,pointer :: ydst(:) ! latitude , for vector, rad + real(SHR_KIND_R8) ,pointer :: wgts(:) ! weights + integer(SHR_KIND_IN),pointer :: isrc(:) ! input grid index + integer(SHR_KIND_IN),pointer :: idst(:) ! output grid index + character(SHR_KIND_CS) :: fill ! string to check if filled + character(SHR_KIND_CS) :: init ! initialization of dst array + end type shr_map_mapType + +! PUBLIC MEMBER FUNCTIONS: + + public :: shr_map_checkInit ! check whether map type is set + public :: shr_map_checkFilled ! check whether map wts are set + public :: shr_map_put ! put stuff into the datatype + public :: shr_map_get ! get stuff out of the datatype + public :: shr_map_mapSet ! compute weights in map + public :: shr_map_mapData ! map data + public :: shr_map_listValidOpts ! list valid options + public :: shr_map_print ! print map datatype info + public :: shr_map_clean ! clean map datatype + public :: shr_map_setAbort ! set abort flag for shr_map + public :: shr_map_setDebug ! set debug level for shr_map + public :: shr_map_setDopole ! set dopole flag + +! PUBLIC DATA MEMBERS: + + !--- Field Strings (fldStr) --- + character(SHR_KIND_CS),public,parameter :: shr_map_fs_name = 'name' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_type = 'type' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_algo = 'algo' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_mask = 'mask' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_vect = 'vect' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_nwts = 'nwts' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_nsrc = 'nsrc' + character(SHR_KIND_CS),public,parameter :: shr_map_fs_ndst = 'ndst' + + !--- "type" options --- + character(len=*),public,parameter :: shr_map_fs_fill = 'fill ' + character(len=*),public,parameter :: shr_map_fs_cfill = 'cfill ' + character(len=*),public,parameter :: shr_map_fs_remap = 'remap ' + + !--- "algorithm" options --- + character(len=*),public,parameter :: shr_map_fs_copy = 'copy ' + character(len=*),public,parameter :: shr_map_fs_bilinear = 'bilinear' + character(len=*),public,parameter :: shr_map_fs_nn = 'nn ' + character(len=*),public,parameter :: shr_map_fs_nnoni = 'nnoni ' + character(len=*),public,parameter :: shr_map_fs_nnonj = 'nnonj ' + character(len=*),public,parameter :: shr_map_fs_spval = 'spval ' + + !--- "mask" options --- + character(len=*),public,parameter :: shr_map_fs_srcmask = 'srcmask ' + character(len=*),public,parameter :: shr_map_fs_dstmask = 'dstmask ' + character(len=*),public,parameter :: shr_map_fs_nomask = 'nomask ' + character(len=*),public,parameter :: shr_map_fs_bothmask = 'bothmask' + + !--- "vect" options --- + character(len=*),public,parameter :: shr_map_fs_scalar = 'scalar ' + character(len=*),public,parameter :: shr_map_fs_vector = 'vector ' + + !--- other public parameters --- + character(SHR_KIND_CS),public,parameter :: shr_map_setTru = 'TRUE map' + character(SHR_KIND_CS),public,parameter :: shr_map_setFal = 'FALSE m ' + integer(SHR_KIND_IN) ,public,parameter :: shr_map_ispval = -99 + real(SHR_KIND_R8) ,public,parameter :: shr_map_spval = shr_const_spval + +!EOP + + !--- Must update these if anything above changes --- + integer(SHR_KIND_IN),public,parameter :: shr_map_fs_ntype = 3 + character(len=*),public,parameter :: & + shr_map_fs_types(shr_map_fs_ntype) = (/shr_map_fs_fill, & + shr_map_fs_cfill, & + shr_map_fs_remap /) + + integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nalgo = 6 + character(len=*),public,parameter :: & + shr_map_fs_algos(shr_map_fs_nalgo) = (/shr_map_fs_copy, & + shr_map_fs_bilinear, & + shr_map_fs_nn, & + shr_map_fs_nnoni, & + shr_map_fs_nnonj, & + shr_map_fs_spval /) + + integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nmask = 4 + character(len=*),public,parameter :: & + shr_map_fs_masks(shr_map_fs_nmask) = (/shr_map_fs_srcmask, & + shr_map_fs_dstmask, & + shr_map_fs_nomask , & + shr_map_fs_bothmask /) + + integer(SHR_KIND_IN),public,parameter :: shr_map_fs_nvect = 2 + character(len=*),public,parameter :: & + shr_map_fs_vects(shr_map_fs_nvect) = (/shr_map_fs_scalar, & + shr_map_fs_vector /) + + interface shr_map_put ; module procedure & + shr_map_putCS, & + shr_map_putR8, & + shr_map_putIN + end interface + + interface shr_map_get ; module procedure & + shr_map_getCS, & + shr_map_getR8, & + shr_map_getIN, & + shr_map_getAR + end interface + + interface shr_map_mapSet ; module procedure & + shr_map_mapSet_global, & + shr_map_mapSet_dest + end interface + + interface shr_map_mapData ; module procedure & + shr_map_mapDatam, & + shr_map_mapDatanm + end interface + + logical,save :: doabort = .true. + logical,save :: dopole = .true. ! for bilinear + integer(SHR_KIND_IN),save :: debug = 0 + character(SHR_KIND_CS),parameter :: fillstring = 'mapisfilled' + character(SHR_KIND_CS),parameter :: inispval = 'spval' + character(SHR_KIND_CS),parameter :: initcopy = 'copy' + real(SHR_KIND_R8) ,parameter :: c0 = 0._SHR_KIND_R8 + real(SHR_KIND_R8) ,parameter :: c1 = 1._SHR_KIND_R8 + real(SHR_KIND_R8) ,parameter :: c2 = 2._SHR_KIND_R8 + real(SHR_KIND_R8) ,parameter :: eps = 1.0e-12_SHR_KIND_R8 + real(SHR_KIND_R8) ,parameter :: pi = shr_const_pi + +!=============================================================================== +contains +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_checkInit -- returns init state of map +! +! !DESCRIPTION: +! Returns init state of map. shr\_map\_checkInit is true +! if the type, algo, and mask are set to valid values. +! \newline +! test = shr\_map\_checkInit(map) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_map_checkInit(map) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType),intent(in) :: map + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkInit') " + +!------------------------------------------------------------------------------- + + if (shr_map_checkFldStrOpt(shr_map_fs_type,map%type) .and. & + shr_map_checkFldStrOpt(shr_map_fs_algo,map%algo) .and. & + shr_map_checkFldStrOpt(shr_map_fs_mask,map%mask)) then + shr_map_checkInit = .true. + else + shr_map_checkInit = .false. + endif + +end function shr_map_checkInit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_checkFilled -- returns fill state of map +! +! !DESCRIPTION: +! Returns fill state of map. shr\_map\_checkFilled is true +! if the number of weights are greater than zero in map +! and if the wgts, isrc, and idst arrays have been allocated to +! that size. +! \newline +! test = shr\_map\_checkFilled(map) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_map_checkFilled(map) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType),intent(in) :: map + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: nwts + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkFilled') " + +!------------------------------------------------------------------------------- + + shr_map_checkFilled = .false. + + nwts = map%nwts + if (map%fill == fillstring .and. nwts >= 0) then + if (size(map%wgts) == nwts .and. size(map%isrc) == nwts & + .and. size(map%idst) == nwts ) then + shr_map_checkFilled = .true. + endif + endif + +end function shr_map_checkFilled + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_checkFldStr -- checks fldstr for validity +! +! !DESCRIPTION: +! Returns true if fldstr is valid (ie. 'type','algo','mask') +! \newline +! test = shr\_map\_checkFldStr('type') +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_map_checkFldStr(fldStr) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) :: fldStr + +!XXEOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkFldStr') " + +!------------------------------------------------------------------------------- + + shr_map_checkFldStr = .false. + + if (trim(fldStr) == trim(shr_map_fs_type).or. & + trim(fldStr) == trim(shr_map_fs_name).or. & + trim(fldStr) == trim(shr_map_fs_algo).or. & + trim(fldStr) == trim(shr_map_fs_mask).or. & + trim(fldStr) == trim(shr_map_fs_vect).or. & + trim(fldStr) == trim(shr_map_fs_nsrc).or. & + trim(fldStr) == trim(shr_map_fs_ndst).or. & + trim(fldStr) == trim(shr_map_fs_nwts)) then + shr_map_checkFldStr = .true. + endif + +end function shr_map_checkFldStr + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_checkFldStrOpt -- checks cval for validity with fldstr +! +! !DESCRIPTION: +! Returns true if cval is valid for fldstr (ie. 'type,remap','algo,bilinear', +! 'mask,srcmask') +! \newline +! test = shr\_map\_checkFldStrOpt(shr_map_fs_algo,'bilinear') +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_map_checkFldStrOpt(fldStr,cval) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: fldStr + character(*),intent(in) :: cval + +!XXEOP + + !--- local --- + integer(SHR_KIND_IN) :: n + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkFldStrOpt') " + +!------------------------------------------------------------------------------- + + shr_map_checkFldStrOpt = .false. + + if (.not.shr_map_checkFldStr(fldStr)) return + + if (trim(fldStr) == trim(shr_map_fs_name)) then + shr_map_checkFldStrOpt = .true. + elseif (trim(fldStr) == trim(shr_map_fs_type)) then + do n = 1,shr_map_fs_ntype + if (trim(cval) == trim(shr_map_fs_types(n))) shr_map_checkFldStrOpt = .true. + enddo + elseif (trim(fldStr) == trim(shr_map_fs_algo)) then + do n = 1,shr_map_fs_nalgo + if (trim(cval) == trim(shr_map_fs_algos(n))) shr_map_checkFldStrOpt = .true. + enddo + elseif (trim(fldStr) == trim(shr_map_fs_mask)) then + do n = 1,shr_map_fs_nmask + if (trim(cval) == trim(shr_map_fs_masks(n))) shr_map_checkFldStrOpt = .true. + enddo + elseif (trim(fldStr) == trim(shr_map_fs_vect)) then + do n = 1,shr_map_fs_nvect + if (trim(cval) == trim(shr_map_fs_vects(n))) shr_map_checkFldStrOpt = .true. + enddo + endif + +end function shr_map_checkFldStrOpt + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_getCS -- get string from map +! +! !DESCRIPTION: +! one of the shr\_map\_get methods for chars +! returns value cval for input fldstr in map +! \newline +! call shr\_map\_get(mymap,shr\_map\_fs\_type,cval) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_getCS(map,fldStr,cval) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(in) :: map + character(*) ,intent(in) :: fldStr + character(*) ,intent(out):: cval + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_getCS') " + +!------------------------------------------------------------------------------- + + cval = shr_map_setFal + if (.not.shr_map_checkFldStr(fldStr)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + return + endif + + if (trim(fldStr) == trim(shr_map_fs_name)) then + cval = map%name + elseif (trim(fldStr) == trim(shr_map_fs_type)) then + cval = map%type + elseif (trim(fldStr) == trim(shr_map_fs_algo)) then + cval = map%algo + elseif (trim(fldStr) == trim(shr_map_fs_mask)) then + cval = map%mask + elseif (trim(fldStr) == trim(shr_map_fs_vect)) then + cval = map%vect + else + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + endif + +end subroutine shr_map_getCS + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_getIN -- get integer from map +! +! !DESCRIPTION: +! one of the shr\_map\_get methods for integers +! returns value ival for input fldstr in map +! \newline +! call shr\_map\_get(mymap,shr\_map\_fs\_nwts,ival) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_getIN(map,fldStr,ival) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(in) :: map + character(*) ,intent(in) :: fldStr + integer(SHR_KIND_IN) ,intent(out):: ival + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_getIN') " + +!------------------------------------------------------------------------------- + + ival = shr_map_ispval + if (.not.shr_map_checkFldStr(fldStr)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + return + endif + + if (trim(fldStr) == trim(shr_map_fs_nwts)) then + ival = map%nwts + elseif (trim(fldStr) == trim(shr_map_fs_nsrc)) then + ival = map%nsrc + elseif (trim(fldStr) == trim(shr_map_fs_ndst)) then + ival = map%ndst + else + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + endif + +end subroutine shr_map_getIN + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_getR8 -- get real from map +! +! !DESCRIPTION: +! one of the shr\_map\_get methods for reals +! returns value rval for input fldstr in map +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_getR8(map,fldStr,rval) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(in) :: map + character(*) ,intent(in) :: fldStr + real(SHR_KIND_R8) ,intent(out):: rval + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_getR8') " + +!------------------------------------------------------------------------------- + + rval = shr_map_spval + if (.not.shr_map_checkFldStr(fldStr)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + return + endif + + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + +end subroutine shr_map_getR8 + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_getAR -- get arrays from map +! +! !DESCRIPTION: +! one of the shr\_map\_get methods for arrays +! returns value ival for input fldstr in map +! \newline +! call shr\_map\_get(mymap,idst,isrc,wgts) +! +! !REVISION HISTORY: +! 2009-Jul-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_getAR(map,isrc,idst,wgts) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(in) :: map + integer(SHR_KIND_IN),pointer,optional :: isrc(:) + integer(SHR_KIND_IN),pointer,optional :: idst(:) + real (SHR_KIND_R8),pointer,optional :: wgts(:) + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: nwts + + !--- formats --- + character(*),parameter :: subName = "('shr_map_getAR') " + +!------------------------------------------------------------------------------- + + nwts = map%nwts + + if (present(isrc)) then + if (size(isrc) < nwts) then + call shr_sys_abort(subName//' ERROR is isrc size') + endif + isrc(1:nwts) = map%isrc(1:nwts) + endif + + if (present(idst)) then + if (size(idst) < nwts) then + call shr_sys_abort(subName//' ERROR is idst size') + endif + idst(1:nwts) = map%idst(1:nwts) + endif + + if (present(wgts)) then + if (size(wgts) < nwts) then + call shr_sys_abort(subName//' ERROR is wgts size') + endif + wgts(1:nwts) = map%wgts(1:nwts) + endif + +end subroutine shr_map_getAR + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_putCS -- put char to map +! +! !DESCRIPTION: +! one of the shr\_map\_put methods for chars +! puts value cval for input fldstr in map +! verify is optional argument that check validity and will +! call abort if cval is not valid option for fldstr. +! \newline +! call shr\_map\_put(mymap,shr\_map\_fs\_algo,shr\_map\_fs\_bilinear) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_putCS(map,fldStr,cval,verify) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map + character(*) ,intent(in) :: fldStr + character(*) ,intent(in) :: cval + logical,optional ,intent(in) :: verify ! check if string is valid + +!EOP + + !--- local --- + logical :: lverify + + !--- formats --- + character(*),parameter :: subName = "('shr_map_putCS') " + +!------------------------------------------------------------------------------- + + lverify = .true. + if (present(verify)) lverify = verify + if (lverify .and. .not.shr_map_checkFldStrOpt(fldStr,cval)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)//' '//trim(cval)) + return + endif + + if (trim(fldStr) == trim(shr_map_fs_name)) then + map%name = cval + elseif (trim(fldStr) == trim(shr_map_fs_type)) then + map%type = cval + elseif (trim(fldStr) == trim(shr_map_fs_algo)) then + map%algo = cval + elseif (trim(fldStr) == trim(shr_map_fs_mask)) then + map%mask = cval + elseif (trim(fldStr) == trim(shr_map_fs_vect)) then + map%vect = cval + else + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + endif + +end subroutine shr_map_putCS + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_putIN -- put integer to map +! +! !DESCRIPTION: +! one of the shr\_map\_put methods for integers +! puts value ival for input fldstr in map +! verify is optional argument that check validity and will +! call abort if ival is not valid option for fldstr. +! \newline +! call shr\_map\_put(mymap,shr\_map\_fs\_nwts,-1) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_putIN(map,fldStr,ival,verify) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map + character(*) ,intent(in) :: fldStr + integer(SHR_KIND_IN) ,intent(in) :: ival + logical,optional ,intent(in) :: verify ! check if string is valid + +!EOP + + !--- local --- + logical :: lverify + + !--- formats --- + character(*),parameter :: subName = "('shr_map_putIN') " + character(*),parameter :: F01 = "('(shr_map_putIN) ',a,i8) " + +!------------------------------------------------------------------------------- + + lverify = .true. + if (present(verify)) lverify = verify + if (lverify .and. .not.shr_map_checkFldStr(fldStr)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + return + endif + + if (trim(fldStr) == trim(shr_map_fs_nwts)) then + map%nwts = ival + elseif (trim(fldStr) == trim(shr_map_fs_nsrc)) then + map%nsrc = ival + elseif (trim(fldStr) == trim(shr_map_fs_ndst)) then + map%ndst = ival + else + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + endif + +end subroutine shr_map_putIN + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_putR8 -- put real to map +! +! !DESCRIPTION: +! one of the shr\_map\_put methods for reals +! puts value rval for input fldstr in map +! verify is optional argument that check validity and will +! call abort if rval is not valid option for fldstr. +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_putR8(map,fldStr,rval,verify) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map + character(*) ,intent(in) :: fldStr + real(SHR_KIND_R8) ,intent(in) :: rval + logical,optional ,intent(in) :: verify ! check if string is valid + +!EOP + + !--- local --- + logical :: lverify + + !--- formats --- + character(*),parameter :: subName = "('shr_map_putR8') " + +!------------------------------------------------------------------------------- + + lverify = .true. + if (present(verify)) lverify = verify + if (lverify .and. .not.shr_map_checkFldStr(fldStr)) then + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + return + endif + + call shr_map_abort(subName//' ERROR illegal fldStr '//trim(fldStr)) + +end subroutine shr_map_putR8 + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_print -- write map to stdout +! +! !DESCRIPTION: +! Write map info to stdout +! \newline +! call shr\_map\_print(mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_print(map) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(in) :: map + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_print') " + character(*),parameter :: F00 = "('(shr_map_print) ',a) " + character(*),parameter :: F01 = "('(shr_map_print) ',a,2l2) " + character(*),parameter :: F02 = "('(shr_map_print) ',a,i8) " + character(*),parameter :: F03 = "('(shr_map_print) ',a,3i8) " + character(*),parameter :: F04 = "('(shr_map_print) ',a,2i8) " + character(*),parameter :: F05 = "('(shr_map_print) ',a,2e20.13) " + + if (s_loglev > 0) then + write(s_logunit,*) ' ' + write(s_logunit,F01) ' name : '//trim(map%name),shr_map_checkInit(map),shr_map_checkFilled(map) + write(s_logunit,F00) ' type : '//trim(map%type) + write(s_logunit,F00) ' algo : '//trim(map%algo) + write(s_logunit,F00) ' mask : '//trim(map%mask) + write(s_logunit,F00) ' vect : '//trim(map%vect) + write(s_logunit,F04) ' gsiz : ',map%nsrc,map%ndst + write(s_logunit,F05) ' xsrc : ',minval(map%xsrc),maxval(map%xsrc) + write(s_logunit,F05) ' ysrc : ',minval(map%ysrc),maxval(map%ysrc) + write(s_logunit,F05) ' xdst : ',minval(map%xdst),maxval(map%xdst) + write(s_logunit,F05) ' ydst : ',minval(map%ydst),maxval(map%ydst) + write(s_logunit,F02) ' nwts : ',map%nwts + write(s_logunit,F03) ' wsiz : ',size(map%wgts),size(map%isrc),size(map%idst) + write(s_logunit,F00) ' init : '//trim(map%init) + + call shr_sys_flush(s_logunit) + endif + +end subroutine shr_map_print + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_listValidOpts -- list the valid switches for map +! +! !DESCRIPTION: +! Lists the valid switches for map, informational only +! \newline +! call shr\_map\_listValidOpts() +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_listValidOpts() + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: n + + !--- formats --- + character(*),parameter :: subName = "('shr_map_listValidOpts') " + character(*),parameter :: F00 = "('(shr_map_listValidOpts) ',a) " + +!------------------------------------------------------------------------------- + + if (s_loglev > 0) then + write(s_logunit,F00) ':' + write(s_logunit,F00) ' '//trim(shr_map_fs_name)//' : any character string' + do n = 1,shr_map_fs_ntype + write(s_logunit,F00) ' '//trim(shr_map_fs_type)//' : '//trim(shr_map_fs_types(n)) + enddo + do n = 1,shr_map_fs_nalgo + write(s_logunit,F00) ' '//trim(shr_map_fs_algo)//' : '//trim(shr_map_fs_algos(n)) + enddo + do n = 1,shr_map_fs_nmask + write(s_logunit,F00) ' '//trim(shr_map_fs_mask)//' : '//trim(shr_map_fs_masks(n)) + enddo + do n = 1,shr_map_fs_nvect + write(s_logunit,F00) ' '//trim(shr_map_fs_vect)//' : '//trim(shr_map_fs_vects(n)) + enddo + call shr_sys_flush(s_logunit) + endif + +end subroutine shr_map_listValidOpts + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_clean -- cleans map +! +! !DESCRIPTION: +! Cleans map by resetting switches, deallocating arrays +! \newline +! call shr\_map\_clean(mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_clean(map) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map + +!EOP + + !--- local --- + integer :: rc + + !--- formats --- + character(*),parameter :: subName = "('shr_map_clean') " + character(*),parameter :: F00 = "('(shr_map_clean) ',a) " + +!------------------------------------------------------------------------------- + + map%fill = ' ' + map%init = ' ' + call shr_map_put(map,shr_map_fs_name,shr_map_setFal,verify=.false.) + call shr_map_put(map,shr_map_fs_type,shr_map_setFal,verify=.false.) + call shr_map_put(map,shr_map_fs_algo,shr_map_setFal,verify=.false.) + call shr_map_put(map,shr_map_fs_mask,shr_map_setFal,verify=.false.) + call shr_map_put(map,shr_map_fs_mask,shr_map_setFal,verify=.false.) + call shr_map_put(map,shr_map_fs_nwts,shr_map_ispval) + call shr_map_put(map,shr_map_fs_nsrc,shr_map_ispval) + call shr_map_put(map,shr_map_fs_ndst,shr_map_ispval) + deallocate(map%xsrc,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' + deallocate(map%ysrc,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' + deallocate(map%xdst,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' + deallocate(map%ydst,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' + deallocate(map%wgts,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map wgts' + deallocate(map%isrc,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map isrc' + deallocate(map%idst,stat=rc) + if (rc > 0.and.debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'Warning: unable to deallocate map idst' + +end subroutine shr_map_clean + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_mapSet_global -- Compute mapping weights +! +! !DESCRIPTION: +! Compute mapping weights based on setting in map. Fill the +! weights in the map. Currently supported maps and action: +! fill :copy = copy array by index, mask switch used +! fill :spval = copy array, fill with spval, mask switch not used +! fill :nn* = copy array, fill with nnval, mask switch not used +! remap:copy = copy array by index, mask switch used +! remap:spval = sets array to spval, mask switch used +! remap:bil* = bilinear interpolation, mask switch used +! remap:nn* = sets array to nnval, mask switch used +! \newline +! Requirements for input grids: +! Xsrc,Ysrc must be regular lat/lon grid, monotonically increasing, +! can be degrees or radians +! Xdst,Ydst are arbitrary list of lats/lons, must be same units as src +! Msrc,Mdst have nonzero for active grid point, zero for non-active +! src and dst must be the grid for type = fill +! Grids are check for validity +! \newline +! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md) +! \newline +! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,algo='bilinear') +! +! !REMARKS +! If bothmask or srcmask is used with remap and some algorithms, active +! dst grid points can have invalid values. A report is produced after +! weights are calculated and this information will be detailed. +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_mapSet_global(map,Xsrc,Ysrc,Msrc,Xdst_in,Ydst,Mdst,name,type,algo,mask,vect,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map ! map + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid + real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid + real(SHR_KIND_R8) ,intent(in) :: Xdst_in(:,:) ! lon of dst grid + real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! lat of dst grid + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! mask of dst grid + character(*) ,optional,intent(in) :: name ! name + character(*) ,optional,intent(in) :: type ! type + character(*) ,optional,intent(in) :: algo ! algo + character(*) ,optional,intent(in) :: mask ! mask + character(*) ,optional,intent(in) :: vect ! vect + integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: nis,njs,nid,njd + integer(SHR_KIND_IN) :: nwts,n,n1,n2,ncnt,i,j,inn,jnn + integer(SHR_KIND_IN) :: irc,lrc + real(SHR_KIND_R8) :: rmin,rmax ! min/max value + real(SHR_KIND_R8) :: cang ! circle angle, deg or rad + real(SHR_KIND_R8),allocatable :: Xdst(:,:) ! lon of dst grid, wrapped as needed + + integer(SHR_KIND_IN) :: pmax ! max num of wgts in pti... + integer(SHR_KIND_IN) :: ptot,ptot2 ! max num of wgts in lis... + integer(SHR_KIND_IN) :: pnum ! num of wgts set in pti... + integer(SHR_KIND_IN),allocatable :: pti(:) ! i index for wgts + integer(SHR_KIND_IN),allocatable :: ptj(:) ! j index for wgts + real(SHR_KIND_R8) ,allocatable :: ptw(:) ! weights for pti,ptj + + integer(SHR_KIND_IN),allocatable :: lis(:) ! tmp src/dst index + integer(SHR_KIND_IN),allocatable :: lid(:) ! tmp src/dst index + real(SHR_KIND_R8) ,allocatable :: lwt(:) ! tmp wgt array + real(SHR_KIND_R8) ,allocatable :: sum(:) ! tmp sum array + integer(SHR_KIND_IN),allocatable :: ltmp(:) ! tmp src/dst index, for resize + real(SHR_KIND_R8) ,allocatable :: lwtmp(:) ! tmp wgt array, for resize + + character(len=8) :: units ! radians or degrees + + logical :: masksrc ! local var to turn on masking using src mask + logical :: maskdst ! local var to turn on masking using dst mask + logical :: maskdstbysrc ! local var to turn on masking using src mask for + ! dst array, especially for fill + logical :: renorm ! local var to turn on renormalization + + !--- formats --- + character(*),parameter :: subName = "('shr_map_mapSet_global') " + character(*),parameter :: F00 = "('(shr_map_mapSet_global) ',a) " + character(*),parameter :: F01 = "('(shr_map_mapSet_global) ',a,l2) " + character(*),parameter :: F02 = "('(shr_map_mapSet_global) ',a,2i8) " + character(*),parameter :: F03 = "('(shr_map_mapSet_global) ',a,2e20.13) " + +!------------------------------------------------------------------------------- + + lrc = 0 + if (present(rc)) rc = lrc + + if (present(name)) call shr_map_put(map,shr_map_fs_name,name) + if (present(type)) call shr_map_put(map,shr_map_fs_type,type,verify=.true.) + if (present(algo)) call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) + if (present(mask)) call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) + if (present(vect)) call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) + map%init = inispval + + if (.NOT.shr_map_checkInit(map)) then + call shr_map_abort(subName//' ERROR map not initialized') + endif + + !--- is lat/lon degrees or radians? --- + cang = 360._SHR_KIND_R8 + units = 'degrees' + if (shr_map_checkRad(Ysrc)) then + cang=c2*pi + units = 'radians' + endif + + nis = size(Xsrc,1) + njs = size(Xsrc,2) + nid = size(Xdst_in,1) + njd = size(Xdst_in,2) + + !--- shift Xdst by 2pi to range of Xsrc as needed --- + allocate(Xdst(nid,njd)) + rmin = minval(Xsrc) + rmax = maxval(Xsrc) + do j=1,njd + do i=1,nid + Xdst(i,j) = Xdst_in(i,j) + do while ((Xdst(i,j) < rmin .and. Xdst(i,j)+cang <= rmax).or. & + (Xdst(i,j) > rmax .and. Xdst(i,j)-cang >= rmin)) + if (Xdst(i,j) < rmin) then + Xdst(i,j) = Xdst(i,j) + cang + elseif (Xdst(i,j) > rmax) then + Xdst(i,j) = Xdst(i,j) - cang + else + call shr_sys_abort(subName//' ERROR in Xdst wrap') + endif + enddo + enddo + enddo + + call shr_map_checkGrids_global(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,lrc) + + map%nwts = 0 + map%nsrc = nis*njs + map%ndst = nid*njd + +! deallocate(map%xsrc,stat=irc) ! this used to be a safe way to delloc when necessary, +! deallocate(map%ysrc,stat=irc) ! but do nothing when pointers were undefined or +! deallocate(map%xdst,stat=irc) ! un-associated, in Oct 2005, undefined ptrs started +! deallocate(map%ydst,stat=irc) ! causing seg-faults on bluesky (B. Kauffman) + allocate(map%xsrc(nis*njs)) + allocate(map%ysrc(nis*njs)) + allocate(map%xdst(nid*njd)) + allocate(map%ydst(nid*njd)) + do j=1,njs + do i=1,nis + call shr_map_2dto1d(n1,nis,njs,i,j) + map%xsrc(n1) = Xsrc(i,j)*c2*pi/cang + map%ysrc(n1) = Ysrc(i,j)*c2*pi/cang + enddo + enddo + do j=1,njd + do i=1,nid + call shr_map_2dto1d(n1,nid,njd,i,j) + map%xdst(n1) = Xdst(i,j)*c2*pi/cang + map%ydst(n1) = Ydst(i,j)*c2*pi/cang + enddo + enddo + + masksrc = .false. + maskdstbysrc = .false. + maskdst = .false. + renorm = .true. + + if (trim(map%type) /= trim(shr_map_fs_fill) .and. & + trim(map%type) /= trim(shr_map_fs_cfill)) then + if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & + trim(map%mask) == trim(shr_map_fs_srcmask)) masksrc = .true. + if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & + trim(map%mask) == trim(shr_map_fs_dstmask)) maskdst = .true. + endif + if (trim(map%algo) == trim(shr_map_fs_spval)) then + masksrc = .false. + renorm = .false. + endif + + if (debug > 1) then + if (s_loglev > 0) write(s_logunit,*) ' ' + call shr_map_print(map) + endif + + if (lrc /= 0) then + if (present(rc)) rc = lrc + return + endif + + if (trim(map%algo) == trim(shr_map_fs_bilinear)) then + if (dopole) then + pmax = nis+2 ! possible for high lat points + ptot = 4*nid*njd ! start with bilinear estimate + else + pmax = 4 ! bilinear with 4 wts/map + ptot = 4*nid*njd + endif + else + pmax = 1 ! nn with 1 wts/map + ptot = 1*nid*njd + endif + allocate(lis(ptot)) + allocate(lid(ptot)) + allocate(lwt(ptot)) + allocate(pti(pmax)) + allocate(ptj(pmax)) + allocate(ptw(pmax)) + + !--- full array copy is default --- + nwts = nid*njd + do n=1,nwts + lid(n) = n + lis(n) = mod(n-1,nis*njs)+1 + lwt(n) = c1 + enddo + + !--- index copy anytime algo = copy --- + if (trim(map%algo) == trim(shr_map_fs_copy)) then + map%init = initcopy + ! just use copy default + + !--- for fill --- + elseif (trim(map%type) == trim(shr_map_fs_fill) .or. & + trim(map%type) == trim(shr_map_fs_cfill)) then + map%init = initcopy + if (trim(map%algo) == trim(shr_map_fs_spval)) then + maskdstbysrc = .true. + elseif (trim(map%algo) == trim(shr_map_fs_nn)) then + do n=1,nwts + call shr_map_1dto2d(lis(n),nis,njs,i,j) + if (Msrc(i,j) == 0) then + call shr_map_findnn(Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then + do n=1,nwts + call shr_map_1dto2d(lis(n),nis,njs,i,j) + if (Msrc(i,j) == 0) then + call shr_map_findnnon('i',Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then + do n=1,nwts + call shr_map_1dto2d(lis(n),nis,njs,i,j) + if (Msrc(i,j) == 0) then + call shr_map_findnnon('j',Xsrc(i,j),Ysrc(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + endif + + !--- for remap --- + elseif (trim(map%type) == trim(shr_map_fs_remap)) then + map%init = inispval + if (trim(map%algo) == trim(shr_map_fs_spval)) then + nwts = 0 + elseif (trim(map%algo) == trim(shr_map_fs_nn)) then + do n=1,nwts + call shr_map_1dto2d(lid(n),nid,njd,i,j) + call shr_map_findnn(Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then + do n=1,nwts + call shr_map_1dto2d(lid(n),nid,njd,i,j) + call shr_map_findnnon('i',Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then + do n=1,nwts + call shr_map_1dto2d(lid(n),nid,njd,i,j) + call shr_map_findnnon('j',Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_bilinear)) then + nwts = 0 + do n=1,nid*njd + call shr_map_1dto2d(n,nid,njd,i,j) + call shr_map_getWts(Xdst(i,j),Ydst(i,j),Xsrc,Ysrc,pti,ptj,ptw,pnum,units) + if (nwts + pnum > size(lwt)) then + !--- resize lis, lid, lwt. ptot is old size, ptot2 is new size + ptot = size(lwt) + ptot2 = ptot + max(ptot/2,pnum*10) + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) 'resize wts ',ptot,ptot2 + allocate(ltmp(ptot)) + ltmp(1:nwts) = lis(1:nwts) + deallocate(lis) + allocate(lis(ptot2)) + lis(1:nwts) = ltmp(1:nwts) + ltmp(1:nwts) = lid(1:nwts) + deallocate(lid) + allocate(lid(ptot2)) + lid(1:nwts) = ltmp(1:nwts) + deallocate(ltmp) + allocate(lwtmp(ptot)) + lwtmp(1:nwts) = lwt(1:nwts) + deallocate(lwt) + allocate(lwt(ptot2)) + lwt(1:nwts) = lwtmp(1:nwts) + deallocate(lwtmp) + endif + do n1 = 1,pnum + nwts = nwts + 1 + lid(nwts) = n + call shr_map_2dto1d(lis(nwts),nis,njs,pti(n1),ptj(n1)) + lwt(nwts) = ptw(n1) + enddo + enddo + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + if (present(rc)) rc = 1 + return + endif + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + if (present(rc)) rc = 1 + return + endif + +!--- compress weights and copy to map --- + !--- remove 1:1 copies if initcopy + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'init: ',map%init + if (map%init == initcopy .and. & + trim(map%type) /= trim(shr_map_fs_cfill)) then + ncnt = 0 + do n=1,nwts + if (lid(n) == lis(n) .and. abs(lwt(n)-c1) < eps) then + ! skipit + else + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove dst grid points --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdst: ',maskdst + if (maskdst) then + ncnt = 0 + do n=1,nwts + call shr_map_1dto2d(lid(n),nid,njd,i,j) + if (Mdst(i,j) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove dst grid points based on src mask--- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdstbysrc: ',maskdstbysrc + if (maskdstbysrc) then + ncnt = 0 + do n=1,nwts + call shr_map_1dto2d(lid(n),nid,njd,i,j) + if (Msrc(i,j) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points by src, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove src grid points --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'masksrc: ',masksrc + if (masksrc) then + ncnt = 0 + do n=1,nwts + call shr_map_1dto2d(lis(n),nis,njs,i,j) + if (Msrc(i,j) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm src grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- renormalize wgts to 1.0 --- + allocate(sum(nid*njd)) + !--- sum weights for dst grid points --- + sum(:) = c0 + do n=1,nwts + sum(lid(n)) = sum(lid(n)) + lwt(n) + enddo + !--- print min/max sum --- + rmin = maxval(sum) + rmax = minval(sum) + do n=1,nid*njd + if (sum(n) > eps) then + rmin = min(rmin,sum(n)) + rmax = max(rmax,sum(n)) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax + !--- renormalize so sum on destination is always 1.0 for active dst points + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'renorm: ',renorm + if (renorm) then + do n=1,nwts + if (sum(lid(n)) > eps) then + lwt(n) = lwt(n) / sum(lid(n)) + endif + enddo + !--- sum weights for dst grid points --- + sum(:) = c0 + do n=1,nwts + sum(lid(n)) = sum(lid(n)) + lwt(n) + enddo + !--- print min/max sum --- + rmin = maxval(sum) + rmax = minval(sum) + do n=1,nid*njd + if (sum(n) > eps) then + rmin = min(rmin,sum(n)) + rmax = max(rmax,sum(n)) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax + endif + + map%nwts = nwts +! deallocate(map%idst,stat=irc) +! deallocate(map%isrc,stat=irc) +! deallocate(map%wgts,stat=irc) + allocate(map%idst(nwts)) + allocate(map%isrc(nwts)) + allocate(map%wgts(nwts)) + do n=1,nwts + map%idst(n) = lid(n) + map%isrc(n) = lis(n) + map%wgts(n) = lwt(n) + enddo + + deallocate(Xdst) + + deallocate(lis) + deallocate(lid) + deallocate(lwt) + deallocate(sum) + + deallocate(pti) + deallocate(ptj) + deallocate(ptw) + + map%fill = fillstring + call shr_map_checkWgts_global(Msrc,Mdst,map) + + if (present(rc)) rc = lrc + +end subroutine shr_map_mapSet_global + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_mapSet_dest -- Compute mapping weights +! +! !DESCRIPTION: +! Compute mapping weights based on setting in map. Fill the +! weights in the map. Currently supported maps and action: +! fill :copy = copy array by index, mask switch used +! fill :spval = copy array, fill with spval, mask switch not used +! fill :nn* = copy array, fill with nnval, mask switch not used +! remap:copy = copy array by index, mask switch used +! remap:spval = sets array to spval, mask switch used +! remap:bil* = bilinear interpolation, mask switch used +! remap:nn* = sets array to nnval, mask switch used +! \newline +! Requirements for input grids: +! Xsrc,Ysrc must be regular lat/lon grid, monotonically increasing +! or decreasing, can be degrees or radians +! Xdst,Ydst are arbitrary list of lats/lons, must be same units as src +! Msrc,Mdst have nonzero for active grid point, zero for non-active +! src and dst must be the grid for type = fill +! Grids are check for validity +! \newline +! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md) +! \newline +! call shr\_map\_mapSet(mymap,Xs,Ys,Ms,Xd,Yd,Md,algo='bilinear') +! +! !REMARKS +! If bothmask or srcmask is used with remap and some algorithms, active +! dst grid points can have invalid values. A report is produced after +! weights are calculated and this information will be detailed. +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_mapSet_dest(map,Xsrc,Ysrc,Msrc,Xdst_in,Ydst,Mdst,ndst,Idst,name,type,algo,mask,vect,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_map_mapType) ,intent(inout):: map ! map + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid + real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid + real(SHR_KIND_R8) ,intent(in) :: Xdst_in(:) ! lon of dst grid + real(SHR_KIND_R8) ,intent(in) :: Ydst(:) ! lat of dst grid + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:) ! mask of dst grid + integer(SHR_KIND_IN) ,intent(in) :: ndst ! global size of dst + integer(SHR_KIND_IN) ,intent(in) :: Idst(:) ! global index of dst grid + character(*) ,optional,intent(in) :: name ! name + character(*) ,optional,intent(in) :: type ! type + character(*) ,optional,intent(in) :: algo ! algo + character(*) ,optional,intent(in) :: mask ! mask + character(*) ,optional,intent(in) :: vect ! vect + integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: nis,njs,nid,njd + integer(SHR_KIND_IN) :: nwts,n,n1,n2,ncnt,i,j,inn,jnn + integer(SHR_KIND_IN) :: irc,lrc + real(SHR_KIND_R8) :: rmin,rmax ! min/max value + real(SHR_KIND_R8) :: cang ! circle angle, deg or rad + real(SHR_KIND_R8),allocatable :: Xdst(:) ! lon of dst grid, wrapped as needed + + integer(SHR_KIND_IN) :: pmax ! max num of wgts in pti... + integer(SHR_KIND_IN) :: ptot,ptot2 ! max num of wgts in lis... + integer(SHR_KIND_IN) :: pnum ! num of wgts set in pti... + integer(SHR_KIND_IN),allocatable :: pti(:) ! i index for wgts + integer(SHR_KIND_IN),allocatable :: ptj(:) ! j index for wgts + real(SHR_KIND_R8) ,allocatable :: ptw(:) ! weights for pti,ptj + + integer(SHR_KIND_IN),allocatable :: lis(:) ! tmp src/dst index + integer(SHR_KIND_IN),allocatable :: lid(:) ! tmp src/dst index + real(SHR_KIND_R8) ,allocatable :: lwt(:) ! tmp wgt array + real(SHR_KIND_R8) ,allocatable :: sum(:) ! tmp sum array + integer(SHR_KIND_IN),allocatable :: ltmp(:) ! tmp src/dst index, for resize + real(SHR_KIND_R8) ,allocatable :: lwtmp(:) ! tmp wgt array, for resize + + character(len=8) :: units ! radians or degrees + + logical :: masksrc ! local var to turn on masking using src mask + logical :: maskdst ! local var to turn on masking using dst mask + logical :: maskdstbysrc ! local var to turn on masking using src mask for + ! dst array, especially for fill + logical :: renorm ! local var to turn on renormalization + + !--- formats --- + character(*),parameter :: subName = "('shr_map_mapSet_dest') " + character(*),parameter :: F00 = "('(shr_map_mapSet_dest) ',a) " + character(*),parameter :: F01 = "('(shr_map_mapSet_dest) ',a,l2) " + character(*),parameter :: F02 = "('(shr_map_mapSet_dest) ',a,2i8) " + character(*),parameter :: F03 = "('(shr_map_mapSet_dest) ',a,2e20.13) " + +!------------------------------------------------------------------------------- + + write(s_logunit,F00) 'ERROR this routine is not validated' + call shr_sys_abort(subName//' ERROR subroutine not validated') + + lrc = 0 + if (present(rc)) rc = lrc + + if (present(name)) call shr_map_put(map,shr_map_fs_name,name) + if (present(type)) call shr_map_put(map,shr_map_fs_type,type,verify=.true.) + if (present(algo)) call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) + if (present(mask)) call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) + if (present(vect)) call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) + map%init = inispval + + if (.NOT.shr_map_checkInit(map)) then + call shr_map_abort(subName//' ERROR map not initialized') + endif + + !--- is lat/lon degrees or radians? --- + cang = 360._SHR_KIND_R8 + units = 'degrees' + if (shr_map_checkRad(Ysrc)) then + cang=c2*pi + units = 'radians' + endif + + nis = size(Xsrc,1) + njs = size(Xsrc,2) + nid = size(Xdst_in,1) + njd = 1 + + !--- shift Xdst by 2pi to range of Xsrc as needed --- + allocate(Xdst(nid)) + rmin = minval(Xsrc) + rmax = maxval(Xsrc) + do i=1,nid + Xdst(i) = Xdst_in(i) + do while ((Xdst(i) < rmin .and. Xdst(i)+cang <= rmax).or. & + (Xdst(i) > rmax .and. Xdst(i)-cang >= rmin)) + if (Xdst(i) < rmin) then + Xdst(i) = Xdst(i) + cang + elseif (Xdst(i) > rmax) then + Xdst(i) = Xdst(i) - cang + else + call shr_sys_abort(subName//' ERROR in Xdst wrap') + endif + enddo + enddo + + call shr_map_checkGrids_dest(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,lrc) + + map%nwts = 0 + map%nsrc = nis*njs + map%ndst = ndst + +! deallocate(map%xsrc,stat=irc) ! this used to be a safe way to delloc when necessary, +! deallocate(map%ysrc,stat=irc) ! but do nothing when pointers were undefined or +! deallocate(map%xdst,stat=irc) ! un-associated, in Oct 2005, undefined ptrs started +! deallocate(map%ydst,stat=irc) ! causing seg-faults on bluesky (B. Kauffman) + allocate(map%xsrc(nis*njs)) + allocate(map%ysrc(nis*njs)) + allocate(map%xdst(nid*njd)) + allocate(map%ydst(nid*njd)) + do j=1,njs + do i=1,nis + call shr_map_2dto1d(n1,nis,njs,i,j) + map%xsrc(n1) = Xsrc(i,j)*c2*pi/cang + map%ysrc(n1) = Ysrc(i,j)*c2*pi/cang + enddo + enddo + do i=1,nid + map%xdst(i) = Xdst(i)*c2*pi/cang + map%ydst(i) = Ydst(i)*c2*pi/cang + enddo + + masksrc = .false. + maskdstbysrc = .false. + maskdst = .false. + renorm = .true. + + if (trim(map%type) /= trim(shr_map_fs_fill) .and. & + trim(map%type) /= trim(shr_map_fs_cfill)) then + if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & + trim(map%mask) == trim(shr_map_fs_srcmask)) masksrc = .true. + if (trim(map%mask) == trim(shr_map_fs_bothmask) .or. & + trim(map%mask) == trim(shr_map_fs_dstmask)) maskdst = .true. + endif + if (trim(map%algo) == trim(shr_map_fs_spval)) then + masksrc = .false. + renorm = .false. + endif + + if (debug > 1) then + if (s_loglev > 0) write(s_logunit,*) ' ' + call shr_map_print(map) + endif + + if (lrc /= 0) then + if (present(rc)) rc = lrc + return + endif + + if (trim(map%algo) == trim(shr_map_fs_bilinear)) then + if (dopole) then + pmax = nis+2 ! possible for high lat points + ptot = 4*nid*njd ! start with bilinear estimate + else + pmax = 4 ! bilinear with 4 wts/map + ptot = 4*nid*njd + endif + else + pmax = 1 ! nn with 1 wts/map + ptot = 1*nid*njd + endif + allocate(lis(ptot)) + allocate(lid(ptot)) + allocate(lwt(ptot)) + allocate(pti(pmax)) + allocate(ptj(pmax)) + allocate(ptw(pmax)) + + !--- full array copy is default --- + nwts = nid*njd + do n=1,nwts + lid(n) = Idst(n) + lis(n) = Idst(n) + lwt(n) = c1 + enddo + + !--- index copy anytime algo = copy --- + if (trim(map%algo) == trim(shr_map_fs_copy)) then + map%init = initcopy + ! just use copy default + + !--- for fill --- + elseif (trim(map%type) == trim(shr_map_fs_fill) .or. & + trim(map%type) == trim(shr_map_fs_cfill)) then + map%init = initcopy + if (trim(map%algo) == trim(shr_map_fs_spval)) then + maskdstbysrc = .true. + elseif (trim(map%algo) == trim(shr_map_fs_nn)) then + do n=1,nwts + if (Mdst(n) == 0) then + call shr_map_findnn(Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then + do n=1,nwts + if (Mdst(n) == 0) then + call shr_map_findnnon('i',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then + do n=1,nwts + if (Mdst(n) == 0) then + call shr_map_findnnon('j',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + endif + enddo + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + endif + + !--- for remap --- + elseif (trim(map%type) == trim(shr_map_fs_remap)) then + map%init = inispval + if (trim(map%algo) == trim(shr_map_fs_spval)) then + nwts = 0 + elseif (trim(map%algo) == trim(shr_map_fs_nn)) then + do n=1,nwts + call shr_map_findnn(Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnoni)) then + do n=1,nwts + call shr_map_findnnon('i',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_nnonj)) then + do n=1,nwts + call shr_map_findnnon('j',Xdst(n),Ydst(n),Xsrc,Ysrc,Msrc,inn,jnn) + call shr_map_2dto1d(lis(n),nis,njs,inn,jnn) + enddo + elseif (trim(map%algo) == trim(shr_map_fs_bilinear)) then + nwts = 0 + do n=1,nid*njd + call shr_map_getWts(Xdst(n),Ydst(n),Xsrc,Ysrc,pti,ptj,ptw,pnum,units) + if (nwts + pnum > size(lwt)) then + !--- resize lis, lid, lwt. ptot is old size, ptot2 is new size + ptot = size(lwt) + ptot2 = ptot + max(ptot/2,pnum*10) + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) 'resize wts ',ptot,ptot2 + allocate(ltmp(ptot)) + ltmp(1:nwts) = lis(1:nwts) + deallocate(lis) + allocate(lis(ptot2)) + lis(1:nwts) = ltmp(1:nwts) + ltmp(1:nwts) = lid(1:nwts) + deallocate(lid) + allocate(lid(ptot2)) + lid(1:nwts) = ltmp(1:nwts) + deallocate(ltmp) + allocate(lwtmp(ptot)) + lwtmp(1:nwts) = lwt(1:nwts) + deallocate(lwt) + allocate(lwt(ptot2)) + lwt(1:nwts) = lwtmp(1:nwts) + deallocate(lwtmp) + endif + do n1 = 1,pnum + nwts = nwts + 1 + lid(nwts) = Idst(n) + call shr_map_2dto1d(lis(nwts),nis,njs,pti(n1),ptj(n1)) + lwt(nwts) = ptw(n1) + enddo + enddo + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + if (present(rc)) rc = 1 + return + endif + else + call shr_map_abort(subName//' ERROR: unsupported map option combo') + if (present(rc)) rc = 1 + return + endif + +!--- compress weights and copy to map --- + !--- remove 1:1 copies if initcopy + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'init: ',map%init + if (map%init == initcopy .and. & + trim(map%type) /= trim(shr_map_fs_cfill)) then + ncnt = 0 + do n=1,nwts + if (lid(n) == lis(n) .and. abs(lwt(n)-c1) < eps) then + ! skipit + else + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove dst grid points --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdst: ',maskdst + if (maskdst) then + ncnt = 0 + do n=1,nwts + if (Mdst(n) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove dst grid points based on src mask--- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'maskdstbysrc: ',maskdstbysrc + if (maskdstbysrc) then + ncnt = 0 + do n=1,nwts + call shr_map_1dto2d(lid(n),nis,njs,i,j) + if (Msrc(i,j) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm dst grid points by src, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- remove src grid points --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'masksrc: ',masksrc + if (masksrc) then + ncnt = 0 + do n=1,nwts + call shr_map_1dto2d(lis(n),nis,njs,i,j) + if (Msrc(i,j) /= 0) then + ncnt = ncnt+1 + lid(ncnt) = lid(n) + lis(ncnt) = lis(n) + lwt(ncnt) = lwt(n) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F02) ' rm src grid points, nwts old/new = ',nwts,ncnt + nwts = ncnt + endif + + !--- renormalize wgts to 1.0 --- + allocate(sum(ndst)) + !--- sum weights for dst grid points --- + sum(:) = c0 + do n=1,nwts + sum(lid(n)) = sum(lid(n)) + lwt(n) + enddo + !--- print min/max sum --- + rmin = maxval(sum) + rmax = minval(sum) + do n=1,ndst + if (sum(n) > eps) then + rmin = min(rmin,sum(n)) + rmax = max(rmax,sum(n)) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax + !--- renormalize so sum on destination is always 1.0 for active dst points + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) 'renorm: ',renorm + if (renorm) then + do n=1,nwts + if (sum(lid(n)) > eps) then + lwt(n) = lwt(n) / sum(lid(n)) + endif + enddo + !--- sum weights for dst grid points --- + sum(:) = c0 + do n=1,nwts + sum(lid(n)) = sum(lid(n)) + lwt(n) + enddo + !--- print min/max sum --- + rmin = maxval(sum) + rmax = minval(sum) + do n=1,nid*njd + if (sum(n) > eps) then + rmin = min(rmin,sum(n)) + rmax = max(rmax,sum(n)) + endif + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F03) 'sum wts min/max ',rmin,rmax + endif + + map%nwts = nwts +! deallocate(map%idst,stat=irc) +! deallocate(map%isrc,stat=irc) +! deallocate(map%wgts,stat=irc) + allocate(map%idst(nwts)) + allocate(map%isrc(nwts)) + allocate(map%wgts(nwts)) + do n=1,nwts + map%idst(n) = lid(n) + map%isrc(n) = lis(n) + map%wgts(n) = lwt(n) + enddo + + deallocate(Xdst) + + deallocate(lis) + deallocate(lid) + deallocate(lwt) + deallocate(sum) + + deallocate(pti) + deallocate(ptj) + deallocate(ptw) + + map%fill = fillstring +!! call shr_map_checkWgts_dest(Msrc,Mdst,map) + + if (present(rc)) rc = lrc + +end subroutine shr_map_mapSet_dest + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_mapDatam -- maps arrays using input map +! +! !DESCRIPTION: +! Maps arrays using preset map +! \newline +! call shr\_map\_mapData(Ain,Aout,mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_mapDatam(arrsrc,arrdst,map) + !--- map arrsrc to arrdst, each array is dimension (fields,grid index) --- + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + real(SHR_KIND_R8) ,intent(in) :: arrsrc(:,:) ! src array(fields,grid) + real(SHR_KIND_R8) ,intent(out):: arrdst(:,:) ! dst array(fields,grid) + type(shr_map_mapType) ,intent(in) :: map ! map + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: n,n2 ! counters + integer(SHR_KIND_IN) :: indi,indo ! array indices, in/out + real(SHR_KIND_R8) :: wgt ! value of weight + integer(SHR_KIND_IN) :: nfi,nfo ! number of fields in array, in/out + integer(SHR_KIND_IN) :: nsi,nso ! size of grid in array, in/out + real(SHR_KIND_R8) :: theta ! angle difference + integer(SHR_KIND_IN),save :: t0=-1,t1,t2,t3,t4,t5 ! timers + integer(SHR_KIND_IN),parameter :: timing=0 ! turn timers off/on (0/1) + logical,pointer :: initnew(:) ! mask for initialization + + !--- formats --- + character(*),parameter :: subName = "('shr_map_mapDatam') " + character(*),parameter :: F00 = "('(shr_map_mapDatam) ',a) " + character(*),parameter :: F01 = "('(shr_map_mapDatam) ',a,2i8) " + +!------------------------------------------------------------------------------- + + if (timing>0 .and. t0 == -1) then + call shr_timer_get(t0,subName//"everything") + call shr_timer_get(t1,subName//"initial checks") + call shr_timer_get(t2,subName//"dst to spval") + call shr_timer_get(t4,subName//"map vector") + call shr_timer_get(t5,subName//"map scalar") + end if + + if (timing>0) call shr_timer_start(t0) + if (timing>0) call shr_timer_start(t1) + + !--- get number of fields --- + nfi = size(arrsrc,1) + nfo = size(arrdst,1) + + !--- check number of fields --- + if (nfi /= nfo) then + write(s_logunit,F01) ' field numbers dont match ',nfi,nfo + call shr_map_abort(subName//' ERROR number of fields') + endif + + !--- check two fields for vector --- + if (trim(map%vect) == trim(shr_map_fs_vector).and.(nfi /= 2)) then + write(s_logunit,F01) ' vector mapping, must map only two fields',nfi,nfo + call shr_map_abort(subName//' ERROR vector mapping fields not two') + endif + + !--- check that map is set --- + if (.not.shr_map_checkFilled(map)) then + write(s_logunit,F00) ' map is not filled' + call shr_map_abort(subName//' ERROR map is not filled') + endif + + !--- get size of grid --- + nsi = size(arrsrc,2) + nso = size(arrdst,2) + + !--- check size of grid --- + if (nsi /= map%nsrc) then + write(s_logunit,F01) ' src grid size doesnt match ',nsi,map%nsrc + call shr_map_abort(subName//' ERROR src grid size') + endif + if (nso /= map%ndst) then + write(s_logunit,F01) ' dst grid size doesnt match ',nso,map%ndst + call shr_map_abort(subName//' ERROR dst grid size') + endif + + if (timing>0) call shr_timer_stop(t1) + if (timing>0) call shr_timer_start(t2) + + allocate(initnew(1:nso)) + initnew = .true. + !--- set arrdst to spval, all points, default --- + if (map%init == inispval) then + arrdst = shr_map_spval + elseif (map%init == initcopy) then + if (nsi /= nso) then + write(s_logunit,F01) ' initcopy has nsi ne nso ',nsi,nso + call shr_map_abort(subName//' ERROR initcopy size') + else + do n = 1,nsi + do n2 = 1,nfo + arrdst(n2,n) = arrsrc(n2,n) + enddo + enddo + endif + else + write(s_logunit,F00) ' map%init illegal '//trim(map%init) + call shr_map_abort(subName//' ERROR map init') + endif + + if (timing>0) call shr_timer_stop(t2) + + !--- generate output array --- + if (trim(map%vect) == trim(shr_map_fs_vector)) then + if (timing>0) call shr_timer_start(t4) + do n=1,map%nwts + indi = map%isrc(n) + indo = map%idst(n) + wgt = map%wgts(n) + theta = map%xdst(indo) - map%xsrc(indi) + if (initnew(indo)) then + initnew(indo) = .false. + arrdst(1,indo) = wgt*( arrsrc(1,indi)*cos(theta) & + +arrsrc(2,indi)*sin(theta)) + arrdst(2,indo) = wgt*(-arrsrc(1,indi)*sin(theta) & + +arrsrc(2,indi)*cos(theta)) + else + arrdst(1,indo) = arrdst(1,indo) + wgt*( arrsrc(1,indi)*cos(theta) & + +arrsrc(2,indi)*sin(theta)) + arrdst(2,indo) = arrdst(2,indo) + wgt*(-arrsrc(1,indi)*sin(theta) & + +arrsrc(2,indi)*cos(theta)) + endif + enddo + if (timing>0) call shr_timer_stop(t4) + else + if (timing>0) call shr_timer_start(t5) + do n=1,map%nwts + indi = map%isrc(n) + indo = map%idst(n) + wgt = map%wgts(n) + if (initnew(indo)) then + initnew(indo) = .false. + do n2 = 1,nfo + arrdst(n2,indo) = arrsrc(n2,indi)*wgt + enddo + else + do n2 = 1,nfo + arrdst(n2,indo) = arrdst(n2,indo) + arrsrc(n2,indi)*wgt + enddo + endif + enddo + if (timing>0) call shr_timer_stop(t5) + endif + + deallocate(initnew) + + if (timing>0) call shr_timer_stop(t0) + +end subroutine shr_map_mapDatam + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_mapDatanm -- maps arrays without map +! +! !DESCRIPTION: +! Maps arrays, don't save the map +! \newline +! call shr\_map\_mapData(Ain,Aout,Xs,Ys,Ms,Xd,Yd,Md,name,type,algo,vect,rc) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_mapDatanm(arrsrc,arrdst,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,name,type,algo,mask,vect,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + !--- map arrsrc to arrdst, each array is dimension (fields,grid index) --- + real(SHR_KIND_R8) ,intent(in) :: arrsrc(:,:) ! src array(fields,grid) + real(SHR_KIND_R8) ,intent(out):: arrdst(:,:) ! dst array(fields,grid) + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! lon of src grid + real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! lat of src grid + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! mask of src grid + real(SHR_KIND_R8) ,intent(in) :: Xdst(:,:) ! lon of dst grid + real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! lat of dst grid + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! mask of dst grid + character(*) ,intent(in) :: name ! name + character(*) ,intent(in) :: type ! type + character(*) ,intent(in) :: algo ! algo + character(*) ,intent(in) :: mask ! mask + character(*) ,optional,intent(in) :: vect ! vect + integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code + +!EOP + + !--- local --- + type(shr_map_mapType) :: map + integer(SHR_KIND_IN) :: lrc + + !--- formats --- + character(*),parameter :: subName = "('shr_map_mapDatanm') " + character(*),parameter :: F00 = "('(shr_map_mapDatanm) ',a) " + +!------------------------------------------------------------------------------- + + lrc = 0 + + call shr_map_put(map,shr_map_fs_name,name,verify=.false.) + call shr_map_put(map,shr_map_fs_type,type,verify=.true.) + call shr_map_put(map,shr_map_fs_algo,algo,verify=.true.) + call shr_map_put(map,shr_map_fs_mask,mask,verify=.true.) + if (present(vect)) then + call shr_map_put(map,shr_map_fs_vect,vect,verify=.true.) + else + call shr_map_put(map,shr_map_fs_vect,'scalar',verify=.true.) + endif + call shr_map_mapSet(map,Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,rc=lrc) + call shr_map_mapData(arrsrc,arrdst,map) + + call shr_map_clean(map) + + if (present(rc)) rc = lrc + +end subroutine shr_map_mapDatanm + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_setAbort -- local interface to abort routine +! +! !DESCRIPTION: +! Set doabort flag for shr_map methods, true = call shr\_sys\_abort, +! false = write error message and continue +! \newline +! call shr\_map\_abort(subName//' ERROR: illegal option') +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_setAbort(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_setAbort') " + character(*),parameter :: F00 = "('(shr_map_setAbort) ',a) " + +!------------------------------------------------------------------------------- + + doabort = flag + +end subroutine shr_map_setAbort + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_setDebug -- set local debug level +! +! !DESCRIPTION: +! Set debug level for shr_map methods, 0 = production +! \newline +! call shr\_map\_setDebug(2) +! +! !REVISION HISTORY: +! 2005-Apr-15 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_setDebug(iflag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(in) :: iflag + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_setDebug') " + character(*),parameter :: F00 = "('(shr_map_setDebug) ',a) " + +!------------------------------------------------------------------------------- + + debug = iflag + +end subroutine shr_map_setDebug + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_map_setDopole -- set dopole flag +! +! !DESCRIPTION: +! set dopole flag +! \newline +! call shr\_map\_setDopole(flag) +! +! !REVISION HISTORY: +! 2009-Jun-22 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_setDopole(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical, intent(in) :: flag + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_map_setDopole') " + character(*),parameter :: F00 = "('(shr_map_setDopole) ',a) " + + dopole = flag + +end subroutine shr_map_setDopole + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_abort -- local interface to abort routine +! +! !DESCRIPTION: +! Local interface to abort routine. Depending on local flag, abort, +! either calls shr\_sys\_abort or writes abort message and continues. +! \newline +! call shr\_map\_abort(subName//' ERROR: illegal option') +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_abort(string) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),optional,intent(in) :: string + +!XXEOP + + !--- local --- + character(shr_kind_CL) :: lstring + + !--- formats --- + character(*),parameter :: subName = "('shr_map_abort') " + character(*),parameter :: F00 = "('(shr_map_abort) ',a) " + +!------------------------------------------------------------------------------- + + lstring = '' + if (present(string)) lstring = string + + if (doabort) then + call shr_sys_abort(lstring) + else + write(s_logunit,F00) trim(lstring) + endif + +end subroutine shr_map_abort + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_checkGrids_global -- local routine to check mapSet grids +! +! !DESCRIPTION: +! Local method to check grid arguments in shr\_map\_mapSet +! \newline +! call shr\_map\_checkGrids_global(Xs,Ys,Ms,Xd,Yd,Md,mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_checkGrids_global(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! src lat + real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! src lon + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask + real(SHR_KIND_R8) ,intent(in) :: Xdst(:,:) ! dst lat + real(SHR_KIND_R8) ,intent(in) :: Ydst(:,:) ! dst lon + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! dst mask + type(shr_map_mapType),intent(in) :: map ! map + integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code + +!XXEOP + + !--- local --- + integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,ncnt + logical :: error,flag + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkGrids_global') " + character(*),parameter :: F00 = "('(shr_map_checkGrids_global) ',a) " + character(*),parameter :: F01 = "('(shr_map_checkGrids_global) ',a,2i8) " + character(*),parameter :: F02 = "('(shr_map_checkGrids_global) ',a,4i8) " + character(*),parameter :: F03 = "('(shr_map_checkGrids_global) ',a,2g20.13) " + character(*),parameter :: F04 = "('(shr_map_checkGrids_global) ',a,i8,a,i8) " + character(*),parameter :: F05 = "('(shr_map_checkGrids_global) ',a,i8,2g20.13) " + character(*),parameter :: F06 = "('(shr_map_checkGrids_global) ',a,2i8,2g20.13) " + +!------------------------------------------------------------------------------- + + error = .false. + if (present(rc)) rc = 0 + + !--- get size of X arrays + nis = size(Xsrc,1) + njs = size(Xsrc,2) + nid = size(Xdst,1) + njd = size(Xdst,2) + + !--- check array size consistency for src and dst + if (size(Ysrc,1) /= nis) then + write(s_logunit,F01) 'ERROR Xsrc,Ysrc i-dim mismatch',nis,size(Ysrc,1) + error = .true. + endif + if (size(Ysrc,2) /= njs) then + write(s_logunit,F01) 'ERROR Xsrc,Ysrc j-dim mismatch',njs,size(Ysrc,2) + error = .true. + endif + if (size(Msrc,1) /= nis) then + write(s_logunit,F01) 'ERROR Xsrc,Msrc i-dim mismatch',nis,size(Msrc,1) + error = .true. + endif + if (size(Msrc,2) /= njs) then + write(s_logunit,F01) 'ERROR Xsrc,Msrc j-dim mismatch',njs,size(Msrc,2) + error = .true. + endif + if (size(Ydst,1) /= nid) then + write(s_logunit,F01) 'ERROR Xdst,Ydst i-dim mismatch',nid,size(Ydst,1) + error = .true. + endif + if (size(Ydst,2) /= njd) then + write(s_logunit,F01) 'ERROR Xdst,Ydst j-dim mismatch',njd,size(Ydst,2) + error = .true. + endif + if (size(Mdst,1) /= nid) then + write(s_logunit,F01) 'ERROR Xdst,Mdst i-dim mismatch',nid,size(Mdst,1) + error = .true. + endif + if (size(Mdst,2) /= njd) then + write(s_logunit,F01) 'ERROR Xdst,Mdst j-dim mismatch',njd,size(Mdst,2) + error = .true. + endif + + !--- fill type must have same grid size on src and dst --- + if (trim(map%type) == trim(shr_map_fs_fill) .or. & + trim(map%type) == trim(shr_map_fs_cfill)) then + if (nis*njs /= nid*njd) then + write(s_logunit,F02) 'ERROR: fill type, src/dst sizes ',nis*njs,nid*njd + error = .true. + endif + endif + + !--- write min/max or X, Y and M count --- + if (debug > 1 .and. s_loglev > 0) then + write(s_logunit,F03) ' Xsrc min/max ',minval(Xsrc),maxval(Xsrc) + write(s_logunit,F03) ' Ysrc min/max ',minval(Ysrc),maxval(Ysrc) + write(s_logunit,F03) ' Xdst min/max ',minval(Xdst),maxval(Xdst) + write(s_logunit,F03) ' Ydst min/max ',minval(Ydst),maxval(Ydst) + endif + + ncnt = 0 + do j=1,njs + do i=1,nis + if (Msrc(i,j) == 0) ncnt = ncnt + 1 + enddo + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Msrc mask T ',nis*njs-ncnt,' of ',nis*njs + + ncnt = 0 + do j=1,njd + do i=1,nid + if (Mdst(i,j) == 0) ncnt = ncnt + 1 + enddo + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Mdst mask T ',nid*njd-ncnt,' of ',nid*njd + + if (trim(map%algo) == trim(shr_map_fs_bilinear)) then + + !--- check that Xsrc is monotonically increasing for bilinear --- + flag = .false. + i = 1 + do while (i < nis .and. .not.flag) + if (((Xsrc(nis,1) > Xsrc(1,1)) .and. (Xsrc(i+1,1) <= Xsrc(i,1))) .or. & + ((Xsrc(nis,1) < Xsrc(1,1)) .and. (Xsrc(i+1,1) >= Xsrc(i,1)))) then + write(s_logunit,F05) 'ERROR Xsrc not monotonic ',i,Xsrc(i+1,1),Xsrc(i,1) + flag = .true. + error = .true. + endif + i = i+1 + enddo + + !--- check that Ysrc is monotonically increasing for bilinear --- + flag = .false. + j = 1 + do while (j < njs .and. .not.flag) + if (((Ysrc(njs,1) > Ysrc(1,1)) .and. (Ysrc(1,j+1) <= Ysrc(1,j))) .or. & + ((Ysrc(njs,1) < Ysrc(1,1)) .and. (Ysrc(1,j+1) >= Ysrc(1,j)))) then + write(s_logunit,F05) 'ERROR Ysrc not monotonic ',i,Ysrc(1,j+1),Ysrc(1,j) + flag = .true. + error = .true. + endif + j = j+1 + enddo + + !--- check that Xsrc and Ysrc are regular lat/lon grids for bilinear + flag = .false. + i = 1 + do while (i < nis .and. .not.flag) + j = 2 + do while (j < njs .and. .not.flag) + if (abs(Xsrc(i,j)-Xsrc(i,1)) > eps) then + write(s_logunit,F06) ' ERROR Xsrc not regular lat,lon ',i,j, & + Xsrc(i,j),Xsrc(1,j) + flag = .true. + error = .true. + endif + j = j+1 + enddo + i = i+1 + enddo + + flag = .false. + j = 1 + do while (j < njs .and. .not.flag) + i = 2 + do while (i < nis .and. .not.flag) + if (abs(Ysrc(i,j)-Ysrc(1,j)) > eps) then + write(s_logunit,F06) ' ERROR Ysrc not regular lat,lon ',i,j, & + Ysrc(i,j),Ysrc(1,j) + flag = .true. + error = .true. + endif + i = i+1 + enddo + j = j+1 + enddo + endif + + if (error) then + call shr_map_abort(subName//' ERROR ') + if (present(rc)) rc = 1 + endif + +end subroutine shr_map_checkGrids_global + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_checkGrids_dest -- local routine to check mapSet grids +! +! !DESCRIPTION: +! Local method to check grid arguments in shr\_map\_mapSet +! \newline +! call shr\_map\_checkGrids_dest(Xs,Ys,Ms,Xd,Yd,Md,mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_checkGrids_dest(Xsrc,Ysrc,Msrc,Xdst,Ydst,Mdst,map,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:) ! src lat + real(SHR_KIND_R8) ,intent(in) :: Ysrc(:,:) ! src lon + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask + real(SHR_KIND_R8) ,intent(in) :: Xdst(:) ! dst lat + real(SHR_KIND_R8) ,intent(in) :: Ydst(:) ! dst lon + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:) ! dst mask + type(shr_map_mapType),intent(in) :: map ! map + integer(SHR_KIND_IN),optional,intent(out) :: rc ! error code + +!XXEOP + + !--- local --- + integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,ncnt + logical :: error,flag + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkGrids_dest') " + character(*),parameter :: F00 = "('(shr_map_checkGrids_dest) ',a) " + character(*),parameter :: F01 = "('(shr_map_checkGrids_dest) ',a,2i8) " + character(*),parameter :: F02 = "('(shr_map_checkGrids_dest) ',a,4i8) " + character(*),parameter :: F03 = "('(shr_map_checkGrids_dest) ',a,2g20.13) " + character(*),parameter :: F04 = "('(shr_map_checkGrids_dest) ',a,i8,a,i8) " + character(*),parameter :: F05 = "('(shr_map_checkGrids_dest) ',a,i8,2g20.13) " + character(*),parameter :: F06 = "('(shr_map_checkGrids_dest) ',a,2i8,2g20.13) " + +!------------------------------------------------------------------------------- + + error = .false. + if (present(rc)) rc = 0 + + !--- get size of X arrays + nis = size(Xsrc,1) + njs = size(Xsrc,2) + nid = size(Xdst,1) + njd = 1 + + !--- check array size consistency for src and dst + if (size(Ysrc,1) /= nis) then + write(s_logunit,F01) 'ERROR Xsrc,Ysrc i-dim mismatch',nis,size(Ysrc,1) + error = .true. + endif + if (size(Ysrc,2) /= njs) then + write(s_logunit,F01) 'ERROR Xsrc,Ysrc j-dim mismatch',njs,size(Ysrc,2) + error = .true. + endif + if (size(Msrc,1) /= nis) then + write(s_logunit,F01) 'ERROR Xsrc,Msrc i-dim mismatch',nis,size(Msrc,1) + error = .true. + endif + if (size(Msrc,2) /= njs) then + write(s_logunit,F01) 'ERROR Xsrc,Msrc j-dim mismatch',njs,size(Msrc,2) + error = .true. + endif + if (size(Ydst,1) /= nid) then + write(s_logunit,F01) 'ERROR Xdst,Ydst i-dim mismatch',nid,size(Ydst,1) + error = .true. + endif + if (size(Mdst,1) /= nid) then + write(s_logunit,F01) 'ERROR Xdst,Mdst i-dim mismatch',nid,size(Mdst,1) + error = .true. + endif + +!--- tcraig, can't check this with dest mapset --- +! !--- fill type must have same grid size on src and dst --- +! if (trim(map%type) == trim(shr_map_fs_fill) .or. & +! trim(map%type) == trim(shr_map_fs_cfill)) then +! if (nis*njs /= nid*njd) then +! write(s_logunit,F02) 'ERROR: fill type, src/dst sizes ',nis*njs,nid*njd +! error = .true. +! endif +! endif + + !--- write min/max or X, Y and M count --- + if (debug > 1 .and. s_loglev > 0) then + write(s_logunit,F03) ' Xsrc min/max ',minval(Xsrc),maxval(Xsrc) + write(s_logunit,F03) ' Ysrc min/max ',minval(Ysrc),maxval(Ysrc) + write(s_logunit,F03) ' Xdst min/max ',minval(Xdst),maxval(Xdst) + write(s_logunit,F03) ' Ydst min/max ',minval(Ydst),maxval(Ydst) + endif + + ncnt = 0 + do j=1,njs + do i=1,nis + if (Msrc(i,j) == 0) ncnt = ncnt + 1 + enddo + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Msrc mask T ',nis*njs-ncnt,' of ',nis*njs + + ncnt = 0 + do i=1,nid + if (Mdst(i) == 0) ncnt = ncnt + 1 + enddo + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F04) ' Mdst mask T ',nid*njd-ncnt,' of ',nid*njd + + if (trim(map%algo) == trim(shr_map_fs_bilinear)) then + + !--- check that Xsrc is monotonically increasing for bilinear --- + flag = .false. + i = 1 + do while (i < nis .and. .not.flag) + if (Xsrc(i+1,1) <= Xsrc(i,1)) then + write(s_logunit,F05) 'ERROR Xsrc not increasing ',i,Xsrc(i+1,1),Xsrc(i,1) + flag = .true. + error = .true. + endif + i = i+1 + enddo + + !--- check that Ysrc is monotonically increasing for bilinear --- + flag = .false. + j = 1 + do while (j < njs .and. .not.flag) + if (Ysrc(1,j+1) <= Ysrc(1,j)) then + write(s_logunit,F05) 'ERROR Ysrc not increasing ',i,Ysrc(1,j+1),Ysrc(1,j) + flag = .true. + error = .true. + endif + j = j+1 + enddo + + !--- check that Xsrc and Ysrc are regular lat/lon grids for bilinear + flag = .false. + i = 1 + do while (i < nis .and. .not.flag) + j = 2 + do while (j < njs .and. .not.flag) + if (abs(Xsrc(i,j)-Xsrc(i,1)) > eps) then + write(s_logunit,F06) ' ERROR Xsrc not regular lat,lon ',i,j, & + Xsrc(i,j),Xsrc(1,j) + flag = .true. + error = .true. + endif + j = j+1 + enddo + i = i+1 + enddo + + flag = .false. + j = 1 + do while (j < njs .and. .not.flag) + i = 2 + do while (i < nis .and. .not.flag) + if (abs(Ysrc(i,j)-Ysrc(1,j)) > eps) then + write(s_logunit,F06) ' ERROR Ysrc not regular lat,lon ',i,j, & + Ysrc(i,j),Ysrc(1,j) + flag = .true. + error = .true. + endif + i = i+1 + enddo + j = j+1 + enddo + endif + + if (error) then + call shr_map_abort(subName//' ERROR ') + if (present(rc)) rc = 1 + endif + +end subroutine shr_map_checkGrids_dest + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_checkWgts_global -- checks weights +! +! !DESCRIPTION: +! Checks weights in map for validity +! \newline +! call shr\_map\_checkWgts_global(Ms,Md,mymap) +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_checkWgts_global(Msrc,Mdst,map) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + integer(SHR_KIND_IN) ,intent(in) :: Msrc(:,:) ! src mask + integer(SHR_KIND_IN) ,intent(in) :: Mdst(:,:) ! dst mask + type(shr_map_mapType),intent(in) :: map ! map + +!XXEOP + + !--- local --- + integer(SHR_KIND_IN) :: i,j,nis,njs,nid,njd,n + integer(SHR_KIND_IN) :: ic1,ic2,ic3,ic4,ic5 ! counters + logical :: error + real(SHR_KIND_R8),allocatable :: Csrc(:,:) + real(SHR_KIND_R8),allocatable :: Cdst(:,:) + + !--- formats --- + character(*),parameter :: subName = "('shr_map_checkWgts_global') " + character(*),parameter :: F00 = "('(shr_map_checkWgts_global) ',a) " + character(*),parameter :: F01 = "('(shr_map_checkWgts_global) ',a,i8) " + character(*),parameter :: F02 = "('(shr_map_checkWgts_global) ',a,3i8) " + character(*),parameter :: F03 = "('(shr_map_checkWgts_global) ',a,i8,a) " + +!------------------------------------------------------------------------------- + + error = .false. + + if (debug > 0) call shr_map_print(map) + + if (map%nwts < 1) then + if (s_loglev > 0) write(s_logunit,F00) 'WARNING map size is zero' + endif + + if (size(map%wgts) /= map%nwts .or. & + size(map%isrc) /= map%nwts .or. & + size(map%idst) /= map%nwts) then + call shr_map_abort(subName//'ERROR sizes inconsistent') + endif + + !--- get size of X arrays + nis = size(Msrc,1) + njs = size(Msrc,2) + nid = size(Mdst,1) + njd = size(Mdst,2) + + allocate(Csrc(nis,njs)) + allocate(Cdst(nid,njd)) + + Csrc = c0 + Cdst = c0 + + do n = 1,map%nwts + call shr_map_1dto2d(map%isrc(n),nis,njs,i,j) + Csrc(i,j) = c1 + call shr_map_1dto2d(map%idst(n),nid,njd,i,j) + Cdst(i,j) = Cdst(i,j) + map%wgts(n) + enddo + + ic1 = 0 + ic2 = 0 + ic3 = 0 + ic4 = 0 + ic5 = 0 + do j=1,njs + do i=1,nis + if (Msrc(i,j) /= 0) then ! live src pt + if (abs(Csrc(i,j)-c1) < eps) then + ic1 = ic1 + 1 ! in use + else + ic2 = ic2 + 1 ! not used + endif + else ! dead src pt + if (abs(Csrc(i,j)-c1) < eps) then + ic3 = ic3 + 1 ! in use + else + ic5 = ic5 + 1 ! not used + endif + endif + enddo + enddo +! if (ic3 > 0) error = .true. + if (debug > 0 .and. s_loglev > 0) then + write(s_logunit,F01) ' total number of SRC points : ',nis*njs + write(s_logunit,F01) ' wgts from SRC TRUE points; used : ',ic1 + write(s_logunit,F01) ' wgts from SRC TRUE points; not used : ',ic2 + write(s_logunit,F01) ' wgts from SRC FALSE points; used : ',ic3 + write(s_logunit,F01) ' wgts from SRC FALSE points; not used : ',ic5 + endif + + ic1 = 0 + ic2 = 0 + ic3 = 0 + ic4 = 0 + ic5 = 0 + do j=1,njd + do i=1,nid + if (Mdst(i,j) /= 0) then ! wgts should sum to one + if (abs(Cdst(i,j)-c1) < eps) then + ic1 = ic1 + 1 ! wgts sum to one + else + ic2 = ic2 + 1 ! invalid wgts + endif + else ! wgts should sum to one or zero + if (abs(Cdst(i,j)-c1) < eps) then + ic3 = ic3 + 1 ! wgts sum to one + elseif (abs(Cdst(i,j)) < eps) then + ic4 = ic4 + 1 ! wgts sum to zero + else + ic5 = ic5 + 1 ! invalid wgts + endif + endif + enddo + enddo +! if (ic2 > 0) error = .true. +! if (ic5 > 0) error = .true. + if (debug > 0 .and. s_loglev > 0) then + write(s_logunit,F01) ' total number of DST points : ',nid*njd + write(s_logunit,F01) ' sum wgts for DST TRUE points; one : ',ic1 + if (ic2 > 0) then + write(s_logunit,F03) ' sum wgts for DST TRUE points; not : ',ic2,' **-WARNING-**' + else + write(s_logunit,F01) ' sum wgts for DST TRUE points; not : ',ic2 + endif + write(s_logunit,F01) ' sum wgts for DST FALSE points; one : ',ic3 + write(s_logunit,F01) ' sum wgts for DST FALSE points; zero : ',ic4 + write(s_logunit,F01) ' sum wgts for DST FALSE points; not : ',ic5 + endif + + deallocate(Csrc) + deallocate(Cdst) + + if (error) call shr_map_abort(subName//' ERROR invalid weights') + +end subroutine shr_map_checkWgts_global + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_map_getWts -- local code that sets weights for a point +! +! !DESCRIPTION: +! Local code that sets weights for a point. Executes searches +! and computes weights. For bilinear remap for example. +! +! !REMARKS: +! Assumes Xsrc,Ysrc are regular lat/lon grids, monotonicallly increasing +! on constant latitude and longitude lines. +! Assumes Xdst,Ydst,Xsrc,Ysrc are all either radians or degrees +! +! !REVISION HISTORY: +! 2005-Mar-27 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_map_getWts(Xdst,Ydst,Xsrc,Ysrc,pti,ptj,ptw,pnum,units) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + +!XXEOP + + real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) + integer(SHR_KIND_IN),intent(out):: pti(:),ptj(:) + real(SHR_KIND_R8) ,intent(out):: ptw(:) + integer(SHR_KIND_IN),intent(out):: pnum + character(len=*),optional,intent(in) :: units + + !--- local --- + integer(SHR_KIND_IN) :: isize,jsize ! array sizes + integer(SHR_KIND_IN) :: i,j ! indices + integer(SHR_KIND_IN) :: n ! do loop counter + integer(SHR_KIND_IN) :: il,ir ! index of i left/mid/right + integer(SHR_KIND_IN) :: jl,ju ! index of j lower/mid/upper + integer(SHR_KIND_IN) :: pmax ! size of pti,ptj,ptw + real(SHR_KIND_R8) :: xsl,xsr ! value of Xsrc, left/right + real(SHR_KIND_R8) :: ysl,ysu ! value of Ysrc, left/right + real(SHR_KIND_R8) :: xd,yd ! value of Xdst,Ydst + real(SHR_KIND_R8) :: dx,dy,dx1,dy1 ! some d_lengths for weights calc + real(SHR_KIND_R8) :: csize ! circle angle/radians + real(SHR_KIND_R8) :: rmin,rmax ! min/max + real(SHR_KIND_R8) :: cpole ! the r8 lat value of the pole + integer(SHR_KIND_IN) :: pole ! 0=no, 1=north, 2=south + + !--- formats --- + character(*),parameter :: subName = "('shr_map_getWts') " + character(*),parameter :: F00 = "('(shr_map_getWts) ',a) " + character(*),parameter :: F02 = "('(shr_map_getWts) ',a,4g20.13) " + character(*),parameter :: F03 = "('(shr_map_getWts) ',a,2g20.13) " + character(*),parameter :: F04 = "('(shr_map_getWts) ',a,4i8) " + character(*),parameter :: F05 = "('(shr_map_getWts) ',a,3g20.13) " + +!------------------------------------------------------------------------------- + + pmax = size(pti,1) + + !--- is lat/lon degrees or radians? needed for X wraparound --- + if (present(units)) then + if (trim(units) == 'degrees') then + csize = 360._SHR_KIND_R8 + elseif (trim(units) == 'radians') then + csize = c2*pi + else + call shr_sys_abort(subName//' ERROR in optional units = '//trim(units)) + endif + else + csize = 360._SHR_KIND_R8 + if (shr_map_checkRad(Ysrc)) csize = c2*pi + endif + + isize = size(Xsrc,1) + jsize = size(Xsrc,2) + pti = 0 + ptj = 0 + ptw = c0 + + cpole = csize/(c2*c2) + + xd = Xdst + yd = Ydst + + if (yd > cpole + 1.0e-3 .or. & + yd < -cpole - 1.0e-3) then + write(s_logunit,*) trim(subname),' ERROR: yd outside bounds ',yd + call shr_map_abort(subName//' ERROR yd outside 90 degree bounds') + endif + if (yd > cpole) yd = cpole + if (yd < -cpole) yd = -cpole + + call shr_map_find4corners(Xdst,yd,Xsrc,Ysrc,il,ir,jl,ju) + + !--- bilinear --- + pnum = 4 + pole = 0 + xsl = Xsrc(il,1) + xsr = Xsrc(ir,1) + ysl = Ysrc(1,jl) + ysu = Ysrc(1,ju) + + if (Xdst < Xsrc(1,1) .or. Xdst > Xsrc(isize,1)) then + xsl = mod(Xsrc(il,1),csize) + xsr = mod(Xsrc(ir,1),csize) + xd = mod(Xdst ,csize) + if (xsl > xd) xsl = xsl - csize + if (xsr < xd) xsr = xsr + csize + endif + + if (yd > Ysrc(1,jsize)) then + if (dopole) then + pnum = isize+2 + pole = 1 + endif + ysu = cpole + elseif (yd < Ysrc(1,1)) then + if (dopole) then + pnum = isize+2 + pole = 2 + endif + ysl = -cpole + endif + + !--- compute dx1,dy1; distance from src(1) to dst + dx = (xsr-xsl) + dy = (ysu-ysl) + dx1 = ( xd-xsl) + dy1 = ( yd-Ysl) + + if (dx1 > dx .and. dx1-dx < 1.0e-7 ) dx1 = dx + if (dy1 > dy .and. dy1-dy < 1.0e-7 ) dy1 = dy + + if (dx <= c0 .or. dy <= c0 .or. dx1 > dx .or. dy1 > dy) then + write(s_logunit,*) ' ' + write(s_logunit,F02) 'ERROR in dx,dy: ',dx1,dx,dy1,dy + write(s_logunit,F03) ' dst: ',Xdst,Ydst + write(s_logunit,F04) ' ind: ',il,ir,jl,ju + write(s_logunit,F02) ' dis: ',dx1,dx,dy1,dy + write(s_logunit,F05) ' x3 : ',xsl,xd,xsr + write(s_logunit,F05) ' y3 : ',ysl,yd,ysu + write(s_logunit,*) ' ' + call shr_map_abort(subName//' ERROR in dx,dy calc') + stop + return + endif + + dx1 = dx1 / dx + dy1 = dy1 / dy + + if (pnum > pmax) then + call shr_sys_abort(subName//' ERROR pti not big enough') + endif + + if (pole == 0) then ! bilinear + + pti(1) = il + pti(2) = ir + pti(3) = il + pti(4) = ir + + ptj(1) = jl + ptj(2) = jl + ptj(3) = ju + ptj(4) = ju + + ptw(1) = (c1-dx1)*(c1-dy1) + ptw(2) = ( dx1)*(c1-dy1) + ptw(3) = (c1-dx1)*( dy1) + ptw(4) = ( dx1)*( dy1) + + elseif (pole == 1) then ! north pole + + pti(1) = il + pti(2) = ir + + ptj(1) = jl + ptj(2) = jl + + ptw(1) = (c1-dx1)*(c1-dy1) + ptw(2) = ( dx1)*(c1-dy1) + + do n=1,isize + pti(2+n) = n + ptj(2+n) = ju + ptw(2+n) = (dy1)/real(isize,SHR_KIND_R8) + enddo + + elseif (pole == 2) then ! south pole + + pti(1) = il + pti(2) = ir + + ptj(1) = ju + ptj(2) = ju + + ptw(1) = (c1-dx1)*( dy1) + ptw(2) = ( dx1)*( dy1) + + do n=1,isize + pti(2+n) = n + ptj(2+n) = jl + ptw(2+n) = (c1-dy1)/real(isize,SHR_KIND_R8) + enddo + + else + + write(s_logunit,F00) ' ERROR illegal pnum situation ' + call shr_map_abort(subName//' ERROR illegal pnum situation') + + endif + +end subroutine shr_map_getWts + +!=============================================================================== + +subroutine shr_map_find4corners(Xdst,Ydst,Xsrc,Ysrc,il,ir,jl,ju) + +! finds 4 corner points surrounding dst in src +! returns left, right, lower, and upper i and j index + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) + integer(SHR_KIND_IN),intent(out):: il,ir,jl,ju + + !--- local --- + integer(SHR_KIND_IN) :: isize,jsize + integer(SHR_KIND_IN) :: im,jm + + !--- formats --- + character(*),parameter :: subName = "('shr_map_find4corners') " + character(*),parameter :: F00 = "('(shr_map_find4corners) ',a,2i8) " + +!------------------------------------------------------------------------------- + + isize = size(Xsrc,1) + jsize = size(Xsrc,2) + + if (Xsrc(isize,1) > Xsrc(1,1)) then + ! increasing Xsrc + if (Xdst < Xsrc(1,1) .or. Xdst > Xsrc(isize,1)) then + il = isize + ir = 1 + else + !--- find i index where Xsrc(i) <= Xdst < Xsrc(i+1) --- + il = 1 + ir = isize + do while (ir-il > 1) + im = (ir+il)/2 + if (Xdst >= Xsrc(im,1)) then + il = im + else + ir = im + endif + enddo + endif + else + ! decreasing Xsrc + if (Xdst > Xsrc(1,1) .or. Xdst < Xsrc(isize,1)) then + il = 1 + ir = isize + else + !--- find i index where Xsrc(i) > Xdst >= Xsrc(i+1) --- + il = isize + ir = 1 + do while (il-ir > 1) + im = (ir+il)/2 + if (Xdst >= Xsrc(im,1)) then + il = im + else + ir = im + endif + enddo + endif + endif + + if (Ysrc(1,jsize) > Ysrc(1,1)) then + ! increasing Ysrc + if (Ydst > Ysrc(1,jsize)) then + jl = jsize + ju = jsize + elseif (Ydst < Ysrc(1,1)) then + jl = 1 + ju = 1 + else + !--- find j index where Ysrc(j) <= Ydst < Ysrc(j+1) --- + jl = 1 + ju = jsize + do while (ju-jl > 1) + jm = (ju+jl)/2 + if (Ydst >= Ysrc(1,jm)) then + jl = jm + else + ju = jm + endif + enddo + endif + else + ! decreasing Ysrc + if (Ydst < Ysrc(1,jsize)) then + jl = jsize + ju = jsize + elseif (Ydst > Ysrc(1,1)) then + jl = 1 + ju = 1 + else + !--- find j index where Ysrc(j) <= Ydst < Ysrc(j+1) --- + jl = jsize + ju = 1 + do while (jl-ju > 1) + jm = (ju+jl)/2 + if (Ydst >= Ysrc(1,jm)) then + jl = jm + else + ju = jm + endif + enddo + endif + endif + +end subroutine shr_map_find4corners + +!=============================================================================== + +subroutine shr_map_findnn(Xdst,Ydst,Xsrc,Ysrc,Msrc,inn,jnn) + +! finds point in src nearest to dst, returns inn,jnn src index +! searches using Msrc active points only + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) + integer(SHR_KIND_IN),intent(in) :: Msrc(:,:) + integer(SHR_KIND_IN),intent(out):: inn,jnn + + !--- local --- + integer(SHR_KIND_IN) :: isize,jsize + integer(SHR_KIND_IN) :: i,j + real(SHR_KIND_R8) :: dnn,dist + + !--- formats --- + character(*),parameter :: subName = "('shr_map_findnn') " + character(*),parameter :: F00 = "('(shr_map_findnn) ',a,2i8) " + +!------------------------------------------------------------------------------- + + isize = size(Xsrc,1) + jsize = size(Xsrc,2) + + inn = -1 + jnn = -1 + dnn = -1._SHR_KIND_R8 + do j=1,jsize + do i=1,isize + if (Msrc(i,j) /= 0) then + dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) + if (dist < dnn .or. inn < 0) then + dnn = dist + inn = i + jnn = j + endif + endif + enddo + enddo + +end subroutine shr_map_findnn + +!=============================================================================== + +subroutine shr_map_findnnon(dir,Xdst,Ydst,Xsrc,Ysrc,Msrc,inn,jnn) + +! finds point in src nearest to dst searching i dir first +! returns inn,jnn src index +! searches using Msrc active points only + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: dir + real(SHR_KIND_R8) ,intent(in) :: Xdst,Ydst + real(SHR_KIND_R8) ,intent(in) :: Xsrc(:,:),Ysrc(:,:) + integer(SHR_KIND_IN),intent(in) :: Msrc(:,:) + integer(SHR_KIND_IN),intent(out):: inn,jnn + + !--- local --- + integer(SHR_KIND_IN) :: isize,jsize + integer(SHR_KIND_IN) :: il,ir,jl,ju + integer(SHR_KIND_IN) :: n,i,j + integer(SHR_KIND_IN) :: is,js + integer(SHR_KIND_IN) :: i2,j2 + real(SHR_KIND_R8) :: dnn,dist,ds + + !--- formats --- + character(*),parameter :: subName = "('shr_map_findnnon') " + character(*),parameter :: F00 = "('(shr_map_findnnon) ',a,2i8) " + +!------------------------------------------------------------------------------- + + isize = size(Xsrc,1) + jsize = size(Xsrc,2) + + !--- find 4 corner points + call shr_map_find4corners(Xdst,Ydst,Xsrc,Ysrc,il,ir,jl,ju) + + !--- find closest of 4 corner points to dst, set that to is,js + is = il + js = jl + ds = shr_map_finddist(Xdst,Ydst,Xsrc(il,jl),Ysrc(il,jl)) + dist = shr_map_finddist(Xdst,Ydst,Xsrc(ir,jl),Ysrc(ir,jl)) + if (dist < ds) then + is = ir + js = jl + ds = dist + endif + dist = shr_map_finddist(Xdst,Ydst,Xsrc(il,ju),Ysrc(il,ju)) + if (dist < ds) then + is = il + js = ju + ds = dist + endif + dist = shr_map_finddist(Xdst,Ydst,Xsrc(ir,ju),Ysrc(ir,ju)) + if (dist < ds) then + is = ir + js = ju + ds = dist + endif + + inn = -1 + jnn = -1 + dnn = -1._SHR_KIND_R8 + i2 = 0 + j2 = 0 + + if (trim(dir) == 'i') then + !--- search biased over i --- + do while (inn < 0 .and. j2 < jsize) + do n=1,2 + if (n == 1) j = min(js + j2,jsize) + if (n == 2) j = max(js - j2,1) + do i=1,isize + if (Msrc(i,j) /= 0) then + dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) + if (dist < dnn .or. inn < 0) then + dnn = dist + inn = i + jnn = j + endif + endif + enddo + enddo + j2 = j2 + 1 + enddo + elseif (trim(dir) == 'j') then + !--- search biased over j --- + do while (inn < 0 .and. i2 < isize) + do n=1,2 + if (n == 1) i = min(is + i2,isize) + if (n == 2) i = max(is - i2,1) + do j=1,jsize + if (Msrc(i,j) /= 0) then + dist = shr_map_finddist(Xdst,Ydst,Xsrc(i,j),Ysrc(i,j)) + if (dist < dnn .or. inn < 0) then + dnn = dist + inn = i + jnn = j + endif + endif + enddo + enddo + i2 = i2 + 1 + enddo + else + call shr_map_abort(subName//' ERROR illegal dir '//trim(dir)) + endif + +end subroutine shr_map_findnnon + +!=============================================================================== + +real(SHR_KIND_R8) function shr_map_finddist(Xdst,Ydst,Xsrc,Ysrc) + +! x,y distance computation + + implicit none + real(SHR_KIND_R8),intent(in) :: Xdst,Ydst,Xsrc,Ysrc + character(*),parameter :: subName = "('shr_map_finddist') " + +!------------------------------------------------------------------------------- + + shr_map_finddist = sqrt((Ydst-Ysrc)**2 + (Xdst-Xsrc)**2) + +end function shr_map_finddist + +!=============================================================================== + +logical function shr_map_checkRad(Grid) + +! check if grid is rad or degree + + implicit none + real(SHR_KIND_R8),intent(in) :: Grid(:,:) + character(*),parameter :: subName = "('shr_map_checkRad') " + real(SHR_KIND_R8) :: rmin,rmax + +!------------------------------------------------------------------------------- + + shr_map_checkRad = .false. + rmin = minval(Grid) + rmax = maxval(Grid) + if ((rmax - rmin) < 1.01_SHR_KIND_R8*c2*pi) shr_map_checkRad = .true. + +end function shr_map_checkRad + +!=============================================================================== + +subroutine shr_map_1dto2d(gid,ni,nj,i,j) + +! convert from a 1d index system to a 2d index system +! gid is 1d index; ni,nj are 2d grid size; i,j are local 2d index + + implicit none + integer(SHR_KIND_IN),intent(in) :: gid,ni,nj + integer(SHR_KIND_IN),intent(out):: i,j + character(*),parameter :: subName = "('shr_map_1dto2d') " + character(*),parameter :: F01 = "('(shr_map_1dto2d) ',a,3i8)" + +!------------------------------------------------------------------------------- + + if (gid < 1 .or. gid > ni*nj) then + write(s_logunit,F01) 'ERROR: illegal gid ',gid,ni,nj + call shr_map_abort(subName//' ERROR') + endif + j = (gid-1)/ni+1 + i = mod(gid-1,ni)+1 + +end subroutine shr_map_1dto2d + +!=============================================================================== + +subroutine shr_map_2dto1d(gid,ni,nj,i,j) + +! convert from a 2d index system to a 1d index system +! gid is 1d index; ni,nj are 2d grid size; i,j are local 2d index + + implicit none + integer(SHR_KIND_IN),intent(in) :: ni,nj,i,j + integer(SHR_KIND_IN),intent(out):: gid + character(*),parameter :: subName = "('shr_map_2dto1d') " + character(*),parameter :: F01 = "('(shr_map_2dto1d) ',a,4i8)" + +!------------------------------------------------------------------------------- + + if (i < 1 .or. i > ni .or. j < 1 .or. j > nj) then + write(s_logunit,F01) 'ERROR: illegal i,j ',i,ni,j,nj + call shr_map_abort(subName//' ERROR') + endif + gid = (j-1)*ni + i + +end subroutine shr_map_2dto1d + +!=============================================================================== +!=============================================================================== +end module shr_map_mod + diff --git a/share/csm_share/shr/shr_mct_mod.F90 b/share/csm_share/shr/shr_mct_mod.F90 new file mode 100644 index 000000000000..9c6259719237 --- /dev/null +++ b/share/csm_share/shr/shr_mct_mod.F90 @@ -0,0 +1,869 @@ +!=============================================================================== +! SVN $Id: shr_mct_mod.F90 18548 2009-09-26 23:55:51Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_091114/shr/shr_mct_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_mct_mod -- higher level mct type routines +! needed to prevent some circular dependencies +! +! !REVISION HISTORY: +! 2009-Dec-16 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ +module shr_mct_mod + +! !USES: + + use shr_kind_mod ! shared kinds + use shr_sys_mod ! share system routines + use shr_mpi_mod ! mpi layer + use shr_const_mod ! constants + use mct_mod + + use shr_log_mod ,only: s_loglev => shr_log_Level + use shr_log_mod ,only: s_logunit => shr_log_Unit + + implicit none + private + +! PUBLIC: Public interfaces + + public :: shr_mct_sMatReadnc + interface shr_mct_sMatPInitnc + module procedure shr_mct_sMatPInitnc_mapfile + end interface + public :: shr_mct_sMatPInitnc + public :: shr_mct_sMatReaddnc + public :: shr_mct_sMatWritednc + public :: shr_mct_queryConfigFile + +!EOP + + !--- local kinds --- + integer,parameter,private :: R8 = SHR_KIND_R8 + integer,parameter,private :: IN = SHR_KIND_IN + integer,parameter,private :: CL = SHR_KIND_CL + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +contains +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +!=============================================================================== +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_mct_sMatReadnc - read all mapping data from a NetCDF SCRIP file +! in to a full SparseMatrix +! +! !DESCRIPTION: +! Read in mapping matrix data from a SCRIP netCDF data file so a sMat. +! +! !REMARKS: +! Based on cpl_map_read +! +! !REVISION HISTORY: +! 2006 Nov 27: R. Jacob +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_mct_sMatReadnc(sMat,fileName) + + use netcdf + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_sMat),intent(inout) :: sMat + character(*),intent(in) :: filename ! netCDF file to read + +!EOP + + !--- local --- + integer(IN) :: n ! generic loop indicies + integer(IN) :: na ! size of source domain + integer(IN) :: nb ! size of destination domain + integer(IN) :: ns ! number of non-zero elements in matrix + integer(IN) :: ni,nj ! number of row and col in the matrix + integer(IN) :: igrow ! aVect index for matrix row + integer(IN) :: igcol ! aVect index for matrix column + integer(IN) :: iwgt ! aVect index for matrix element + + real(R8) ,allocatable :: rtemp(:) ! reals + integer(IN),allocatable :: itemp(:) ! ints + + integer(IN) :: rcode ! netCDF routine return code + integer(IN) :: fid ! netCDF file ID + integer(IN) :: vid ! netCDF variable ID + integer(IN) :: did ! netCDF dimension ID + + character(*),parameter :: subName = '(shr_mct_sMatReadnc) ' + character(*),parameter :: F00 = "('(shr_mct_sMatReadnc) ',4a)" + character(*),parameter :: F01 = '("(shr_mct_sMatReadnc) ",2(a,i9))' + + if (s_loglev > 0) write(s_logunit,F00) "reading mapping matrix data..." + + !---------------------------------------------------------------------------- + ! open & read the file + !---------------------------------------------------------------------------- + if (s_loglev > 0) write(s_logunit,F00) "* file name : ",trim(fileName) + rcode = nf90_open(filename,NF90_NOWRITE,fid) + if (rcode /= NF90_NOERR) then + write(s_logunit,F00) nf90_strerror(rcode) + call mct_die(subName,"error opening Netcdf file") + endif + + !--- allocate memory & get matrix data ---------- + rcode = nf90_inq_dimid (fid, 'n_s', did) ! size of sparse matrix + rcode = nf90_inquire_dimension(fid, did, len=ns) + rcode = nf90_inq_dimid (fid, 'n_a', did) ! size of input vector + rcode = nf90_inquire_dimension(fid, did, len=na) + rcode = nf90_inq_dimid (fid, 'n_b', did) ! size of output vector + rcode = nf90_inquire_dimension(fid, did, len=nb) + + if (s_loglev > 0) write(s_logunit,F01) "* matrix dimensions src x dst: ",na,' x',nb + if (s_loglev > 0) write(s_logunit,F01) "* number of non-zero elements: ",ns + + !---------------------------------------------------------------------------- + ! init the mct sMat data type + !---------------------------------------------------------------------------- + ! mct_sMat_init must be given the number of rows and columns that + ! would be in the full matrix. Nrows= size of output vector=nb. + ! Ncols = size of input vector = na. + call mct_sMat_init(sMat, nb, na, ns) + + igrow = mct_sMat_indexIA(sMat,'grow') + igcol = mct_sMat_indexIA(sMat,'gcol') + iwgt = mct_sMat_indexRA(sMat,'weight') + + !!!!!!!!!!!!!!!!!!!!!!!!!! + ! read and load matrix weights + allocate(rtemp(ns),stat=rcode) + if (rcode /= 0) & + call mct_die(subName,':: allocate weights',rcode) + + rcode = nf90_inq_varid(fid, 'S',vid) + rcode = nf90_get_var(fid, vid, rtemp) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + + sMat%data%rAttr(iwgt ,:) = rtemp(:) + + deallocate(rtemp, stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: deallocate weights',rcode) + + !!!!!!!!!!!!!!!!!!!!!!!!!! + ! read and load rows + allocate(itemp(ns),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate rows',rcode) + + rcode = nf90_inq_varid(fid, 'row', vid) + rcode = nf90_get_var(fid, vid, itemp) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + + sMat%data%iAttr(igrow,:) = itemp(:) + + + !!!!!!!!!!!!!!!!!!!!!!!!!! + ! read and load columns + itemp(:) = 0 + + rcode = nf90_inq_varid(fid, 'col', vid) + rcode = nf90_get_var(fid, vid, itemp) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + + sMat%data%iAttr(igcol,:) = itemp(:) + + deallocate(itemp, stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: deallocate cols',rcode) + + rcode = nf90_close(fid) + + if (s_loglev > 0) write(s_logunit,F00) "... done reading file" + call shr_sys_flush(s_logunit) + +end subroutine shr_mct_sMatReadnc + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_mct_queryConfigFile - get mct config file info +! +! !DESCRIPTION: +! Query MCT config file variables +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2013 Aug 17: T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_mct_queryConfigFile(mpicom, ConfigFileName, & + Label1,Value1,Label2,Value2,Label3,Value3) + +! !INPUT/OUTPUT PARAMETERS: + integer ,intent(in) :: mpicom + character(len=*), intent(in) :: ConfigFileName + character(len=*), intent(in) :: Label1 + character(len=*), intent(out) :: Value1 + character(len=*), intent(in) ,optional :: Label2 + character(len=*), intent(out),optional :: Value2 + character(len=*), intent(in) ,optional :: Label3 + character(len=*), intent(out),optional :: Value3 + +!EOP + integer :: iret + character(*),parameter :: subName = '(shr_mct_queryConfigFile) ' + + call I90_allLoadF(ConfigFileName,0,mpicom,iret) + if(iret /= 0) then + write(s_logunit,*) trim(subname),"Cant find config file ",ConfigFileName + call shr_sys_abort(trim(subname)//' File Not Found') + endif + + call i90_label(trim(Label1),iret) + if(iret /= 0) then + write(s_logunit,*) trim(subname),"Cant find label ",Label1 + call shr_sys_abort(trim(subname)//' Label1 Not Found') + endif + + call i90_gtoken(Value1,iret) + if(iret /= 0) then + write(s_logunit,*) trim(subname),"Error reading token ",Value1 + call shr_sys_abort(trim(subname)//' Error on read value1') + endif + + if (present(Label2) .and. present(Value2)) then + + call i90_label(trim(Label2),iret) + if(iret /= 0) then + write(s_logunit,*) trim(subname),"Cant find label ",Label2 + call shr_sys_abort(trim(subname)//' Label2 Not Found') + endif + + call i90_gtoken(Value2,iret) + if(iret /= 0) then + write(s_logunit,*)"Error reading token ",Value2 + call shr_sys_abort(trim(subname)//' Error on read value2') + endif + + endif + + if (present(Label3) .and. present(Value3)) then + + call i90_label(trim(Label3),iret) + if(iret /= 0) then + write(s_logunit,*) trim(subname),"Cant find label ",Label3 + call shr_sys_abort(trim(subname)//' Label3 Not Found') + endif + + call i90_gtoken(Value3,iret) + if(iret /= 0) then + write(s_logunit,*)"Error reading token ",Value3 + call shr_sys_abort(trim(subname)//' Error on read value3') + endif + + endif + + call I90_Release(iret) + +end subroutine shr_mct_queryConfigFile + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_mct_sMatPInitnc_mapfile - initialize a SparseMatrixPlus. +! +! !DESCRIPTION: +! Read in mapping matrix data from a SCRIP netCDF data file in first an +! Smat and then an SMatPlus +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2012 Feb 27: M. Vertenstein +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_mct_sMatPInitnc_mapfile(sMatP, gsMapX, gsMapY, & + filename, maptype, mpicom, & + ni_i, nj_i, ni_o, nj_o, & + areasrc, areadst) + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_sMatP),intent(inout) :: sMatP + type(mct_gsMap),intent(in) :: gsMapX + type(mct_gsMap),intent(in) :: gsMapY + character(*) ,intent(in) :: filename ! scrip map file to read + character(*) ,intent(in) :: maptype ! map type + integer ,intent(in) :: mpicom + integer ,intent(out), optional :: ni_i ! number of longitudes on input grid + integer ,intent(out), optional :: nj_i ! number of latitudes on input grid + integer ,intent(out), optional :: ni_o ! number of longitudes on output grid + integer ,intent(out), optional :: nj_o ! number of latitudes on output grid + type(mct_Avect),intent(out), optional :: areasrc ! area of src grid from mapping file + type(mct_Avect),intent(out), optional :: areadst ! area of src grid from mapping file + +!EOP + type(mct_sMat ) :: sMati ! initial sMat from read (either root or decomp) + type(mct_Avect) :: areasrc_map ! area of src grid from mapping file + type(mct_Avect) :: areadst_map ! area of dst grid from mapping file + + integer :: lsize + integer :: iret + integer :: pe_loc + logical :: usevector + character(len=3) :: Smaptype + character(*),parameter :: areaAV_field = 'aream' + character(*),parameter :: F00 = "('(shr_mct_sMatPInitnc) ',4a)" + character(*),parameter :: F01 = "('(shr_mct_sMatPInitnc) ',a,i10)" + + call shr_mpi_commrank(mpicom,pe_loc) + + if (s_loglev > 0) write(s_logunit,*) " " + if (s_loglev > 0) write(s_logunit,F00) "Initializing SparseMatrixPlus" + if (s_loglev > 0) write(s_logunit,F00) "SmatP mapname ",trim(filename) + if (s_loglev > 0) write(s_logunit,F00) "SmatP maptype ",trim(maptype) + + if (maptype == "X") then + Smaptype = "src" + else if(maptype == "Y") then + Smaptype = "dst" + end if + + call shr_mpi_commrank(mpicom, pe_loc) + + lsize = mct_gsMap_lsize(gsMapX, mpicom) + call mct_aVect_init(areasrc_map, rList=areaAV_field, lsize=lsize) + + lsize = mct_gsMap_lsize(gsMapY, mpicom) + call mct_aVect_init(areadst_map, rList=areaAV_field, lsize=lsize) + + if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then + call shr_mct_sMatReaddnc(sMati, gsMapX, gsMapY, Smaptype, areasrc_map, areadst_map, & + fileName, pe_loc, mpicom, ni_i, nj_i, ni_o, nj_o) + else + call shr_mct_sMatReaddnc(sMati, gsMapX, gsMapY, Smaptype, areasrc_map, areadst_map, & + fileName, pe_loc, mpicom) + end if + call mct_sMatP_Init(sMatP, sMati, gsMapX, gsMapY, 0, mpicom, gsMapX%comp_id) + +#ifdef CPP_VECTOR + !--- initialize the vector parts of the sMat --- + call mct_sMatP_Vecinit(sMatP) +#endif + + lsize = mct_smat_gNumEl(sMatP%Matrix,mpicom) + if (s_loglev > 0) write(s_logunit,F01) "Done initializing SmatP, nElements = ",lsize + +#ifdef CPP_VECTOR + usevector = .true. +#else + usevector = .false. +#endif + if (present(areasrc)) then + call mct_aVect_copy(aVin=areasrc_map, aVout=areasrc, vector=usevector) + end if + if (present(areadst)) then + call mct_aVect_copy(aVin=areadst_map, aVout=areadst, vector=usevector) + end if + + call mct_aVect_clean(areasrc_map) + call mct_aVect_clean(areadst_map) + + call mct_sMat_Clean(sMati) + +end subroutine shr_mct_sMatPInitnc_mapfile + +!BOP =========================================================================== +! +! !IROUTINE: shr_mct_sMatReaddnc - Do a distributed read of a NetCDF SCRIP file and +! return weights in a distributed SparseMatrix +! +! !DESCRIPTION: +! Read in mapping matrix data from a SCRIP netCDF data file using +! a low memory method and then scatter to all pes. +! +! !REMARKS: +! This routine leverages gsmaps to determine scatter pattern +! The scatter is implemented as a bcast of all weights then a local +! computation on each pe to determine with weights to keep based +! on gsmap information. +! The algorithm to determine whether a weight belongs on a pe involves +! creating a couple local arrays (lsstart and lscount) which are +! the local values of start and length from the gsmap. these are +! sorted via a bubble sort and then searched via a binary search +! to check whether a global index is on the local pe. +! The local buffer sizes are estimated up front based on ngridcell/npes +! plus 20% (see 1.2 below). If the local buffer size fills up, then +! the buffer is reallocated 50% large (see 1.5 below) and the fill +! continues. The idea is to trade off memory reallocation and copy +! with memory usage. 1.2 and 1.5 are arbitary, other values may +! result in better performance. +! Once all the matrix weights have been read, the sMat is initialized, +! the values from the buffers are copied in, and everything is deallocated. + +! !SEE ALSO: +! mct/m_SparseMatrix.F90 (MCT source code) +! +! !REVISION HISTORY: +! 2007-Jan-18 - T. Craig -- first version +! 2007-Mar-20 - R. Jacob -- rename to shr_mct_sMatReaddnc. Remove use of cpl_ +! variables and move to shr_mct_mod +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_mct_sMatReaddnc(sMat,SgsMap,DgsMap,newdom,areasrc,areadst, & + fileName,mytask, mpicom, ni_i,nj_i,ni_o,nj_o ) + +! !USES: + + use netcdf + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_sMat) ,intent(out) :: sMat ! mapping data + type(mct_gsMap) ,intent(in) ,target :: SgsMap ! src gsmap + type(mct_gSMap) ,intent(in) ,target :: DgsMap ! dst gsmap + character(*) ,intent(in) :: newdom ! type of sMat (src or dst) + type(mct_Avect) ,intent(out), optional :: areasrc ! area of src grid from mapping file + type(mct_Avect) ,intent(out), optional :: areadst ! area of dst grid from mapping file + character(*) ,intent(in) :: filename! netCDF file to read + integer(IN) ,intent(in) :: mytask ! processor id + integer(IN) ,intent(in) :: mpicom ! communicator + integer(IN) ,intent(out), optional :: ni_i ! number of lons on input grid + integer(IN) ,intent(out), optional :: nj_i ! number of lats on input grid + integer(IN) ,intent(out), optional :: ni_o ! number of lons on output grid + integer(IN) ,intent(out), optional :: nj_o ! number of lats on output grid + +! !EOP + + !--- local --- + integer(IN) :: n,m ! generic loop indicies + integer(IN) :: na ! size of source domain + integer(IN) :: nb ! size of destination domain + integer(IN) :: ns ! number of non-zero elements in matrix + integer(IN) :: ni,nj ! number of row and col in the matrix + integer(IN) :: igrow ! aVect index for matrix row + integer(IN) :: igcol ! aVect index for matrix column + integer(IN) :: iwgt ! aVect index for matrix element + integer(IN) :: iarea ! aVect index for area + integer(IN) :: rsize ! size of read buffer + integer(IN) :: cnt ! local num of wgts + integer(IN) :: cntold ! local num of wgts, previous read + integer(IN) :: start(1)! netcdf read + integer(IN) :: count(1)! netcdf read + integer(IN) :: bsize ! buffer size + integer(IN) :: nread ! number of reads + logical :: mywt ! does this weight belong on my pe + + !--- buffers for i/o --- + real(R8) ,allocatable :: rtemp(:) ! real temporary + real(R8) ,allocatable :: Sbuf(:) ! real weights + integer(IN),allocatable :: Rbuf(:) ! ints rows + integer(IN),allocatable :: Cbuf(:) ! ints cols + + !--- variables associated with local computation of global indices + integer(IN) :: lsize ! size of local seg map + integer(IN) :: commsize ! size of local communicator + integer(IN),allocatable :: lsstart(:) ! local seg map info + integer(IN),allocatable :: lscount(:) ! local seg map info + type(mct_gsMap),pointer :: mygsmap ! pointer to one of the gsmaps + integer(IN) :: l1,l2 ! generice indices for sort + logical :: found ! for sort + + !--- variable assocaited with local data buffers and reallocation + real(R8) ,allocatable :: Snew(:),Sold(:) ! reals + integer(IN),allocatable :: Rnew(:),Rold(:) ! ints + integer(IN),allocatable :: Cnew(:),Cold(:) ! ints + + character,allocatable :: str(:) ! variable length char string + character(CL) :: attstr ! netCDF attribute name string + integer(IN) :: rcode ! netCDF routine return code + integer(IN) :: fid ! netCDF file ID + integer(IN) :: vid ! netCDF variable ID + integer(IN) :: did ! netCDF dimension ID + !--- arbitrary size of read buffer, this is the chunk size weights reading + integer(IN),parameter :: rbuf_size = 100000 + + !--- global source and destination areas --- + type(mct_Avect) :: areasrc0 ! area of src grid from mapping file + type(mct_Avect) :: areadst0 ! area of src grid from mapping file + + character(*),parameter :: areaAV_field = 'aream' + + !--- formats --- + character(*),parameter :: subName = '(shr_mct_sMatReaddnc) ' + character(*),parameter :: F00 = '("(shr_mct_sMatReaddnc) ",4a)' + character(*),parameter :: F01 = '("(shr_mct_sMatReaddnc) ",2(a,i10))' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_mpi_commsize(mpicom,commsize) + if (mytask == 0) then + if (s_loglev > 0) write(s_logunit,F00) "reading mapping matrix data decomposed..." + + !---------------------------------------------------------------------------- + ! open & read the file + !---------------------------------------------------------------------------- + if (s_loglev > 0) write(s_logunit,F00) "* file name : ",trim(fileName) + rcode = nf90_open(filename,NF90_NOWRITE,fid) + if (rcode /= NF90_NOERR) then + print *,'Failed to open file ',trim(filename) + call shr_sys_abort(trim(subName)//nf90_strerror(rcode)) + end if + + + !--- get matrix dimensions ---------- + rcode = nf90_inq_dimid(fid, 'n_s', did) ! size of sparse matrix + rcode = nf90_inquire_dimension(fid, did, len=ns) + rcode = nf90_inq_dimid(fid, 'n_a', did) ! size of input vector + rcode = nf90_inquire_dimension(fid, did, len=na) + rcode = nf90_inq_dimid(fid, 'n_b', did) ! size of output vector + rcode = nf90_inquire_dimension(fid, did, len=nb) + + if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then + rcode = nf90_inq_dimid(fid, 'ni_a', did) ! number of lons in input grid + rcode = nf90_inquire_dimension(fid, did, len=ni_i) + rcode = nf90_inq_dimid(fid, 'nj_a', did) ! number of lats in input grid + rcode = nf90_inquire_dimension(fid, did, len=nj_i) + rcode = nf90_inq_dimid(fid, 'ni_b', did) ! number of lons in output grid + rcode = nf90_inquire_dimension(fid, did, len=ni_o) + rcode = nf90_inq_dimid(fid, 'nj_b', did) ! number of lats in output grid + rcode = nf90_inquire_dimension(fid, did, len=nj_o) + end if + + if (s_loglev > 0) write(s_logunit,F01) "* matrix dims src x dst : ",na,' x',nb + if (s_loglev > 0) write(s_logunit,F01) "* number of non-zero elements: ",ns + + endif + + !--- read and load area_a --- + if (present(areasrc)) then + if (mytask == 0) then + call mct_aVect_init(areasrc0,' ',areaAV_field,na) + rcode = nf90_inq_varid(fid, 'area_a', vid) + if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) + rcode = nf90_get_var(fid, vid, areasrc0%rAttr) + if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) + endif + call mct_aVect_scatter(areasrc0, areasrc, SgsMap, 0, mpicom, rcode) + if (rcode /= 0) call mct_die("shr_mct_sMatReaddnc","Error on scatter of areasrc0") + if (mytask == 0) then +! if (present(dbug)) then +! if (dbug > 2) then +! write(6,*) subName,'Size of src ',mct_aVect_lSize(areasrc0) +! write(6,*) subName,'min/max src ',minval(areasrc0%rAttr(1,:)),maxval(areasrc0%rAttr(1,:)) +! endif +! end if + call mct_aVect_clean(areasrc0) + end if + end if + + !--- read and load area_b --- + if (present(areadst)) then + if (mytask == 0) then + call mct_aVect_init(areadst0,' ',areaAV_field,nb) + rcode = nf90_inq_varid(fid, 'area_b', vid) + if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) + rcode = nf90_get_var(fid, vid, areadst0%rAttr) + if (rcode /= NF90_NOERR) write(6,F00) nf90_strerror(rcode) + endif + call mct_aVect_scatter(areadst0, areadst, DgsMap, 0, mpicom, rcode) + if (rcode /= 0) call mct_die("shr_mct_sMatReaddnc","Error on scatter of areadst0") + if (mytask == 0) then +! if (present(dbug)) then +! if (dbug > 2) then +! write(6,*) subName,'Size of dst ',mct_aVect_lSize(areadst0) +! write(6,*) subName,'min/max dst ',minval(areadst0%rAttr(1,:)),maxval(areadst0%rAttr(1,:)) +! endif +! end if + call mct_aVect_clean(areadst0) + endif + endif + + if (present(ni_i) .and. present(nj_i) .and. present(ni_o) .and. present(nj_o)) then + call shr_mpi_bcast(ni_i,mpicom,subName//" MPI in ni_i bcast") + call shr_mpi_bcast(nj_i,mpicom,subName//" MPI in nj_i bcast") + call shr_mpi_bcast(ni_o,mpicom,subName//" MPI in ni_o bcast") + call shr_mpi_bcast(nj_o,mpicom,subName//" MPI in nj_o bcast") + end if + + call shr_mpi_bcast(ns,mpicom,subName//" MPI in ns bcast") + call shr_mpi_bcast(na,mpicom,subName//" MPI in na bcast") + call shr_mpi_bcast(nb,mpicom,subName//" MPI in nb bcast") + + !--- setup local seg map, sorted + if (newdom == 'src') then + mygsmap => DgsMap + elseif (newdom == 'dst') then + mygsmap => SgsMap + else + write(s_logunit,F00) 'ERROR: invalid newdom value = ',newdom + call shr_sys_abort(trim(subName)//" invalid newdom value") + endif + lsize = 0 + do n = 1,size(mygsmap%start) + if (mygsmap%pe_loc(n) == mytask) then + lsize=lsize+1 + endif + enddo + allocate(lsstart(lsize),lscount(lsize),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate Lsstart',rcode) + + lsize = 0 + do n = 1,size(mygsmap%start) + if (mygsmap%pe_loc(n) == mytask) then ! on my pe + lsize=lsize+1 + found = .false. + l1 = 1 + do while (.not.found .and. l1 < lsize) ! bubble sort copy + if (mygsmap%start(n) < lsstart(l1)) then + do l2 = lsize, l1+1, -1 + lsstart(l2) = lsstart(l2-1) + lscount(l2) = lscount(l2-1) + enddo + found = .true. + else + l1 = l1 + 1 + endif + enddo + lsstart(l1) = mygsmap%start(n) + lscount(l1) = mygsmap%length(n) + endif + enddo + do n = 1,lsize-1 + if (lsstart(n) > lsstart(n+1)) then + write(s_logunit,F00) ' ERROR: lsstart not properly sorted' + call shr_sys_abort() + endif + enddo + + rsize = min(rbuf_size,ns) ! size of i/o chunks + bsize = ((ns/commsize) + 1 ) * 1.2 ! local temporary buffer size + if (ns == 0) then + nread = 0 + else + nread = (ns-1)/rsize + 1 ! num of reads to do + endif + + allocate(Sbuf(rsize),Rbuf(rsize),Cbuf(rsize),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate Sbuf',rcode) + allocate(Snew(bsize),Cnew(bsize),Rnew(bsize),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate Snew1',rcode) + + cnt = 0 + do n = 1,nread + start(1) = (n-1)*rsize + 1 + count(1) = min(rsize,ns-start(1)+1) + + !--- read data on root pe + if (mytask== 0) then + rcode = nf90_inq_varid(fid, 'S', vid) + rcode = nf90_get_var(fid, vid, Sbuf, start, count) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + + rcode = nf90_inq_varid(fid, 'row', vid) + rcode = nf90_get_var(fid, vid, Rbuf, start, count) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + + rcode = nf90_inq_varid(fid, 'col', vid) + rcode = nf90_get_var(fid, vid, Cbuf, start, count) + if (rcode /= NF90_NOERR .and. s_loglev > 0) then + write(s_logunit,F00) nf90_strerror(rcode) + end if + endif + + !--- send S, row, col to all pes + call shr_mpi_bcast(Sbuf,mpicom,subName//" MPI in Sbuf bcast") + call shr_mpi_bcast(Rbuf,mpicom,subName//" MPI in Rbuf bcast") + call shr_mpi_bcast(Cbuf,mpicom,subName//" MPI in Cbuf bcast") + + !--- now each pe keeps what it should + do m = 1,count(1) + !--- should this weight be on my pe + if (newdom == 'src') then + mywt = mct_myindex(Rbuf(m),lsstart,lscount) + elseif (newdom == 'dst') then + mywt = mct_myindex(Cbuf(m),lsstart,lscount) + endif + + if (mywt) then + cntold = cnt + cnt = cnt + 1 + + !--- new arrays need to be bigger + if (cnt > bsize) then + !--- allocate old arrays and copy new into old + allocate(Sold(cntold),Rold(cntold),Cold(cntold),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate old',rcode) + Sold(1:cntold) = Snew(1:cntold) + Rold(1:cntold) = Rnew(1:cntold) + Cold(1:cntold) = Cnew(1:cntold) + + !--- reallocate new to bigger size, increase buffer by 50% (arbitrary) + deallocate(Snew,Rnew,Cnew,stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate new',rcode) + bsize = 1.5 * bsize + if (s_loglev > 1) write(s_logunit,F01) ' reallocate bsize to ',bsize + allocate(Snew(bsize),Rnew(bsize),Cnew(bsize),stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: allocate old',rcode) + + !--- copy data back into new + Snew(1:cntold) = Sold(1:cntold) + Rnew(1:cntold) = Rold(1:cntold) + Cnew(1:cntold) = Cold(1:cntold) + deallocate(Sold,Rold,Cold,stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: deallocate old',rcode) + endif + + Snew(cnt) = Sbuf(m) + Rnew(cnt) = Rbuf(m) + Cnew(cnt) = Cbuf(m) + endif + enddo ! count + enddo ! nread + + deallocate(Sbuf,Rbuf,Cbuf, stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: deallocate Sbuf',rcode) + + !---------------------------------------------------------------------------- + ! init the mct sMat data type + !---------------------------------------------------------------------------- + ! mct_sMat_init must be given the number of rows and columns that + ! would be in the full matrix. Nrows= size of output vector=nb. + ! Ncols = size of input vector = na. + call mct_sMat_init(sMat, nb, na, cnt) + + igrow = mct_sMat_indexIA(sMat,'grow') + igcol = mct_sMat_indexIA(sMat,'gcol') + iwgt = mct_sMat_indexRA(sMat,'weight') + + if (cnt /= 0) then + sMat%data%rAttr(iwgt ,1:cnt) = Snew(1:cnt) + sMat%data%iAttr(igrow,1:cnt) = Rnew(1:cnt) + sMat%data%iAttr(igcol,1:cnt) = Cnew(1:cnt) + endif + deallocate(Snew,Rnew,Cnew, stat=rcode) + deallocate(lsstart,lscount,stat=rcode) + if (rcode /= 0) call mct_perr_die(subName,':: deallocate new',rcode) + + if (mytask == 0) then + rcode = nf90_close(fid) + if (s_loglev > 0) write(s_logunit,F00) "... done reading file" + call shr_sys_flush(s_logunit) + endif + +end subroutine shr_mct_sMatReaddnc + +!BOP =========================================================================== +! +! !IROUTINE: shr_mct_sMatWritednc - Do a distributed write of a NetCDF SCRIP file +! based on a distributed SparseMatrix +! +! !DESCRIPTION: +! Write out mapping matrix data from a SCRIP netCDF data file using +! a low memory method. +! +! !SEE ALSO: +! mct/m_SparseMatrix.F90 (MCT source code) +! +! !REVISION HISTORY: +! 2009-Dec-15 - T. Craig -- first version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_mct_sMatWritednc(sMat,iosystem, io_type, fileName,compid, mpicom) + +! !USES: + use pio, only : iosystem_desc_t + use shr_pcdf_mod, only : shr_pcdf_readwrite + implicit none +#include + +! !INPUT/OUTPUT PARAMETERS: + + type(mct_sMat) ,intent(in) :: sMat ! mapping data + type(iosystem_desc_t) :: iosystem ! PIO subsystem description + integer(IN) ,intent(in) :: io_type ! type of io interface for this file + character(*) ,intent(in) :: filename ! netCDF file to read + integer(IN) ,intent(in) :: compid ! processor id + integer(IN) ,intent(in) :: mpicom ! communicator + + ! !local + integer(IN) :: na,nb,ns,lsize,npes,ierr,my_task,n + integer(IN), pointer :: start(:),count(:),ssize(:),pe_loc(:) + integer(IN), pointer :: expvari(:) + real(R8) , pointer :: expvarr(:) + type(mct_gsmap) :: gsmap + type(mct_avect) :: AV + character(*),parameter :: subName = '(shr_mct_sMatWritednc) ' + +!---------------------------------------- + + call MPI_COMM_SIZE(mpicom,npes,ierr) + call MPI_COMM_RANK(mpicom,my_task,ierr) + allocate(start(npes),count(npes),ssize(npes),pe_loc(npes)) + + na = mct_sMat_ncols(sMat) + nb = mct_sMat_nrows(sMat) + ns = mct_sMat_gNumEl(sMat,mpicom) + lsize = mct_sMat_lsize(sMat) + + count(:) = -999 + pe_loc(:) = -999 + ssize(:) = 1 + call MPI_GATHER(lsize,1,MPI_INTEGER,count,ssize,MPI_INTEGER,0,mpicom,ierr) + + if (my_task == 0) then + if (minval(count) < 0) then + call shr_sys_abort(subname//' ERROR: count invalid') + endif + + start(1) = 1 + pe_loc(1) = 0 + do n = 2,npes + start(n) = start(n-1)+count(n-1) + pe_loc(n) = n-1 + enddo + + endif + + call mct_gsmap_init(gsmap,npes,start,count,pe_loc,0,mpicom,compid,ns) + deallocate(start,count,ssize,pe_loc) + + call mct_aVect_init(AV,iList='row:col',rList='S',lsize=lsize) + allocate(expvari(lsize)) + call mct_sMat_ExpGRowI(sMat,expvari) + AV%iAttr(1,:) = expvari(:) + call mct_sMat_ExpGColI(sMat,expvari) + AV%iAttr(2,:) = expvari(:) + deallocate(expvari) + allocate(expvarr(lsize)) + call mct_sMat_ExpMatrix(sMat,expvarr) + AV%rAttr(1,:) = expvarr(:) + deallocate(expvarr) + + call shr_pcdf_readwrite('write',iosystem,io_type, trim(filename),mpicom,gsmap,clobber=.false.,cdf64=.true., & + id1=na,id1n='n_a',id2=nb,id2n='n_b',id3=ns,id3n='n_s',av1=AV,av1n='') + + call mct_gsmap_clean(gsmap) + call mct_avect_clean(AV) + +end subroutine shr_mct_sMatWritednc +!=============================================================================== + +end module shr_mct_mod + diff --git a/share/csm_share/shr/shr_mem_mod.F90 b/share/csm_share/shr/shr_mem_mod.F90 new file mode 100644 index 000000000000..c21d6d3db082 --- /dev/null +++ b/share/csm_share/shr/shr_mem_mod.F90 @@ -0,0 +1,101 @@ +!=============================================================================== +! SVN $Id: shr_const_mod.F90 6354 2007-09-11 22:49:33Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk/shr/shr_const_mod.F90 $ +!=============================================================================== + +MODULE shr_mem_mod + + use shr_kind_mod, only : shr_kind_r8 + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + private + +! PUBLIC: Public interfaces + + public :: shr_mem_getusage, & + shr_mem_init + +! PUBLIC: Public interfaces + + real(shr_kind_r8) :: mb_blk = 0.0_shr_kind_r8 + +!=============================================================================== +CONTAINS +!=============================================================================== + +subroutine shr_mem_init(prt) + + implicit none + + !----- arguments ----- + + logical, optional :: prt + + !----- local ----- + + ! --- Memory stats --- + integer :: msize ! memory size (high water) + integer :: mrss ! resident size (current memory use) + integer :: msize0,msize1 ! temporary size + integer :: mrss0,mrss1,mrss2 ! temporary rss + integer :: mshare,mtext,mdatastack + logical :: lprt + integer :: ierr + + integer :: GPTLget_memusage + + real(shr_kind_r8),allocatable :: mem_tmp(:) + + !--------------------------------------------------- + + lprt = .false. + if (present(prt)) then + lprt = prt + endif + + ierr = GPTLget_memusage (msize, mrss0, mshare, mtext, mdatastack) + allocate(mem_tmp(1024*1024)) ! 1 MWord, 8 MB + mem_tmp = -1.0 + ierr = GPTLget_memusage (msize, mrss1, mshare, mtext, mdatastack) + deallocate(mem_tmp) + ierr = GPTLget_memusage (msize, mrss2, mshare, mtext, mdatastack) + mb_blk = 0.0_shr_kind_r8 + if (mrss1 - mrss0 > 0) then + mb_blk = (8.0_shr_kind_r8)/((mrss1-mrss0)*1.0_shr_kind_r8) + endif + + if (lprt) then + write(s_logunit,'(A,f16.2)') '8 MB memory alloc in MB is ',(mrss1-mrss0)*mb_blk + write(s_logunit,'(A,f16.2)') '8 MB memory dealloc in MB is ',(mrss1-mrss2)*mb_blk + write(s_logunit,'(A,f16.2)') 'Memory block size conversion in bytes is ',mb_blk*1024_shr_kind_r8*1024.0_shr_kind_r8 + endif + +end subroutine shr_mem_init + +!=============================================================================== + +subroutine shr_mem_getusage(r_msize,r_mrss) + + implicit none + + !----- arguments --- + real(shr_kind_r8) :: r_msize,r_mrss + + !----- local --- + integer :: msize,mrss + integer :: mshare,mtext,mdatastack + integer :: ierr + integer :: GPTLget_memusage + + !--------------------------------------------------- + + ierr = GPTLget_memusage (msize, mrss, mshare, mtext, mdatastack) + r_msize = msize*mb_blk + r_mrss = mrss*mb_blk + +end subroutine shr_mem_getusage + +!=============================================================================== + +END MODULE shr_mem_mod diff --git a/share/csm_share/shr/shr_mpi_mod.F90 b/share/csm_share/shr/shr_mpi_mod.F90 new file mode 100644 index 000000000000..71ad7a0f29b0 --- /dev/null +++ b/share/csm_share/shr/shr_mpi_mod.F90 @@ -0,0 +1,2222 @@ +!=============================================================================== +! SVN $Id: shr_mpi_mod.F90 65839 2014-11-30 14:40:15Z jedwards $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_mpi_mod.F90 $ +!=============================================================================== + +Module shr_mpi_mod + +!------------------------------------------------------------------------------- +! PURPOSE: general layer on MPI functions +!------------------------------------------------------------------------------- + + use shr_kind_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + private + +! PUBLIC: Public interfaces + + public :: shr_mpi_chkerr + public :: shr_mpi_send + public :: shr_mpi_recv + public :: shr_mpi_bcast + public :: shr_mpi_gathScatVInit + public :: shr_mpi_gatherV + public :: shr_mpi_scatterV + public :: shr_mpi_sum + public :: shr_mpi_min + public :: shr_mpi_max + public :: shr_mpi_commsize + public :: shr_mpi_commrank + public :: shr_mpi_initialized + public :: shr_mpi_abort + public :: shr_mpi_barrier + public :: shr_mpi_init + public :: shr_mpi_finalize + + interface shr_mpi_send ; module procedure & + shr_mpi_sendi0, & + shr_mpi_sendi1, & + shr_mpi_sendr0, & + shr_mpi_sendr1, & + shr_mpi_sendr3 + end interface + interface shr_mpi_recv ; module procedure & + shr_mpi_recvi0, & + shr_mpi_recvi1, & + shr_mpi_recvr0, & + shr_mpi_recvr1, & + shr_mpi_recvr3 + end interface + interface shr_mpi_bcast ; module procedure & + shr_mpi_bcastc0, & + shr_mpi_bcastc1, & + shr_mpi_bcastl0, & + shr_mpi_bcastl1, & + shr_mpi_bcasti0, & + shr_mpi_bcasti1, & + shr_mpi_bcasti80, & + shr_mpi_bcasti81, & + shr_mpi_bcasti2, & + shr_mpi_bcastr0, & + shr_mpi_bcastr1, & + shr_mpi_bcastr2, & + shr_mpi_bcastr3 + end interface + interface shr_mpi_gathScatVInit ; module procedure & + shr_mpi_gathScatVInitr1 + end interface + interface shr_mpi_gatherv ; module procedure & + shr_mpi_gatherVr1 + end interface + interface shr_mpi_scatterv ; module procedure & + shr_mpi_scatterVr1 + end interface + interface shr_mpi_sum ; module procedure & + shr_mpi_sumi0, & + shr_mpi_sumi1, & + shr_mpi_sumb0, & + shr_mpi_sumb1, & + shr_mpi_sumr0, & + shr_mpi_sumr1, & + shr_mpi_sumr2, & + shr_mpi_sumr3 + end interface + interface shr_mpi_min ; module procedure & + shr_mpi_mini0, & + shr_mpi_mini1, & + shr_mpi_minr0, & + shr_mpi_minr1 + end interface + interface shr_mpi_max ; module procedure & + shr_mpi_maxi0, & + shr_mpi_maxi1, & + shr_mpi_maxr0, & + shr_mpi_maxr1 + end interface + +#include ! mpi library include file + +!=============================================================================== +CONTAINS +!=============================================================================== + +SUBROUTINE shr_mpi_chkerr(rcode,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code + character(*), intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_chkerr) ' + character(MPI_MAX_ERROR_STRING) :: lstring + integer(SHR_KIND_IN) :: len + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: layer on MPI error checking +!------------------------------------------------------------------------------- + + if (rcode /= MPI_SUCCESS) then + call MPI_ERROR_STRING(rcode,lstring,len,ierr) + write(s_logunit,*) trim(subName),":",lstring(1:len) + call shr_mpi_abort(string,rcode) + endif + +END SUBROUTINE shr_mpi_chkerr + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! send value + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendi0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Send a single integer +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_sendi0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendi1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Send a vector of integers +!------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_sendi1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Send a real scalar +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_sendr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Send a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_sendr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real (SHR_KIND_R8), intent(in) :: array(:,:,:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sendr3) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Send a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(array) + + call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_sendr3 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(out):: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvi0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Recv a vector of reals +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_recvi0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(out):: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvi1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Recv a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_recvi1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(out):: lvec ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr0) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Recv a vector of reals +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_recvr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(out):: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr1) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Recv a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(lvec) + + call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_recvr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string) + + IMPLICIT none + + !----- arguments --- + real (SHR_KIND_R8), intent(out):: array(:,:,:) ! in/out local values + integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from + integer(SHR_KIND_IN), intent(in) :: tag ! tag + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_recvr3) ' + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Recv a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(array) + + call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_recvr3 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast an integer +!------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti0 + +SUBROUTINE shr_mpi_bcasti80(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast an integer + !------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti80 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + logical, intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastl0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a logical +!------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastl0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + character(len=*), intent(inout) :: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastc0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a character string +!------------------------------------------------------------------------------- + + lsize = len(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastc0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + character(len=*), intent(inout) :: vec(:) ! 1D vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastc1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a character string +!------------------------------------------------------------------------------- + + lsize = size(vec)*len(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastc1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastr0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a real +!------------------------------------------------------------------------------- + + lsize = 1 + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a vector of integers +!------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti1 + +SUBROUTINE shr_mpi_bcasti81(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !------------------------------------------------------------------------------- + ! PURPOSE: Broadcast a vector of integers + !------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti81 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + logical, intent(inout):: vec(:) ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastl1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a logical +!------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastl1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(inout):: vec(:) ! vector + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastr1) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a vector of reals +!------------------------------------------------------------------------------- + + lsize = size(vec) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(inout):: arr(:,:) ! array, 2d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcastr2) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a 2d array of reals +!------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastr2 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + integer, intent(inout):: arr(:,:) ! array, 2d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcasti2) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a 2d array of integers +!------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti2 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(inout):: arr(:,:,:) ! array, 3d + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: lpebcast + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_bcastr3) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a 3d array of reals +!------------------------------------------------------------------------------- + + lsize = size(arr) + lpebcast = 0 + if (present(pebcast)) lpebcast = pebcast + + call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastr3 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, & + displs, string ) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather/scatter on + real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array of distributed data + real(SHR_KIND_R8), pointer :: glob1DArr(:) ! Global 1D array of gathered data + integer(SHR_KIND_IN), pointer :: globSize(:) ! Size of each distributed piece + integer(SHR_KIND_IN), pointer :: displs(:) ! Displacements for receive + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: npes ! Number of MPI tasks + integer(SHR_KIND_IN) :: locSize ! Size of local distributed data + integer(SHR_KIND_IN), pointer :: sendSize(:) ! Size to send for initial gather + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: rank ! Rank of this MPI task + integer(SHR_KIND_IN) :: nSize ! Maximum size to send + integer(SHR_KIND_IN) :: ierr ! Error code + integer(SHR_KIND_IN) :: nSiz1D ! Size of 1D global array + integer(SHR_KIND_IN) :: maxSize ! Maximum size + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_gathScatvInitr1) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Setup arrays for a gatherv/scatterv operation +!------------------------------------------------------------------------------- + + locSize = size(locarr) + call shr_mpi_commsize( comm, npes ) + call shr_mpi_commrank( comm, rank ) + allocate( globSize(npes) ) + ! + ! --- Gather the send global sizes from each MPI task ----------------------- + ! + allocate( sendSize(npes) ) + sendSize(:) = 1 + globSize(:) = 1 + call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, & + MPI_INTEGER, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + deallocate( sendSize ) + ! + ! --- Prepare the displacement and allocate arrays ------------------------- + ! + allocate( displs(npes) ) + displs(1) = 0 + if ( rootid /= rank )then + maxSize = 1 + globSize = 1 + else + maxSize = maxval(globSize) + end if + nsiz1D = min(maxSize,globSize(1)) + do i = 2, npes + nSize = min(maxSize,globSize(i-1)) + displs(i) = displs(i-1) + nSize + nsiz1D = nsiz1D + min(maxSize,globSize(i)) + end do + allocate( glob1DArr(nsiz1D) ) + !----- Do some error checking for the root task arrays computed ---- + if ( rootid == rank )then + if ( nsiz1D /= sum(globSize) ) & + call shr_mpi_abort( subName//" : Error, size of global array not right" ) + if ( any(displs < 0) .or. any(displs >= nsiz1D) ) & + call shr_mpi_abort( subName//" : Error, displacement array not right" ) + if ( (displs(npes)+globSize(npes)) /= nsiz1D ) & + call shr_mpi_abort( subName//" : Error, displacement array values too big" ) + end if + +END SUBROUTINE shr_mpi_gathScatvInitr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, & + comm, string ) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array + real(SHR_KIND_R8), intent(inout):: glob1DArr(:) ! Global 1D array to receive in on + integer(SHR_KIND_IN), intent(in) :: locSize ! Number to send this PE + integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to receive each PE + integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for receive + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather on + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: ierr ! Error code + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_gathervr1) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Gather a 1D array of reals +!------------------------------------------------------------------------------- + + call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, & + MPI_REAL8, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_gathervr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, & + comm, string ) + + IMPLICIT none + + !----- arguments ----- + real(SHR_KIND_R8), intent(out) :: locarr(:) ! Local array + real(SHR_KIND_R8), intent(in) :: glob1Darr(:) ! Global 1D array to send from + integer(SHR_KIND_IN), intent(in) :: locSize ! Number to receive this PE + integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to send to each PE + integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for send + integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to scatter on + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local ----- + integer(SHR_KIND_IN) :: ierr ! Error code + + !----- formats ----- + character(*),parameter :: subName = '(shr_mpi_scattervr1) ' + +!------------------------------------------------------------------------------- +! PURPOSE: Scatter a 1D array of reals +!------------------------------------------------------------------------------- + + + call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, & + MPI_REAL8, rootid, comm, ierr ) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_scattervr1 + + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumi0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumi0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumi1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumi1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_I8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumb0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumb0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_I8), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_I8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumb1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumb1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:,:)! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:,:)! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr2) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumr2 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:,:,:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:,:,:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_sumr3) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds sum of a distributed vector of values, assume local sum +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_SUM + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_sumr3 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_mini0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds min of a distributed vector of values, assume local min +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_mini0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_mini1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds min of a distributed vector of values, assume local min +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_mini1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_minr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds min of a distributed vector of values, assume local min +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_minr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_minr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds min of a distributed vector of values, assume local min +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MIN + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_minr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxi0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds max of a distributed vector of values, assume local max +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_maxi0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values + integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxi1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds max of a distributed vector of values, assume local max +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_maxi1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxr0) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds max of a distributed vector of values, assume local max +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = 1 + gsize = 1 + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_maxr0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all) + + IMPLICIT none + + !----- arguments --- + real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values + real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + logical, optional,intent(in) :: all ! allreduce if true + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_maxr1) ' + logical :: lall + character(SHR_KIND_CL) :: lstring + integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type + integer(SHR_KIND_IN) :: lsize + integer(SHR_KIND_IN) :: gsize + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: Finds max of a distributed vector of values, assume local max +! already computed +!------------------------------------------------------------------------------- + + reduce_type = MPI_MAX + if (present(all)) then + lall = all + else + lall = .false. + endif + if (present(string)) then + lstring = trim(subName)//":"//trim(string) + else + lstring = trim(subName) + endif + + lsize = size(lvec) + gsize = size(gvec) + + if (lsize /= gsize) then + call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) + endif + + if (lall) then + call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") + else + call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) + call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") + endif + +END SUBROUTINE shr_mpi_maxr1 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_commsize(comm,size,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + integer,intent(out) :: size + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_commsize) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI commsize +!------------------------------------------------------------------------------- + + call MPI_COMM_SIZE(comm,size,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_commsize + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_commrank(comm,rank,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + integer,intent(out) :: rank + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_commrank) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI commrank +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(comm,rank,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_commrank + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_initialized(flag,string) + + IMPLICIT none + + !----- arguments --- + logical,intent(out) :: flag + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_initialized) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI initialized +!------------------------------------------------------------------------------- + + call MPI_INITIALIZED(flag,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_initialized + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_abort(string,rcode) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + integer,optional,intent(in) :: rcode ! optional code + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_abort) ' + integer(SHR_KIND_IN) :: ierr + integer :: rc ! return code + +!------------------------------------------------------------------------------- +! PURPOSE: MPI abort +!------------------------------------------------------------------------------- + + if ( present(string) .and. present(rcode) ) then + write(s_logunit,*) trim(subName),":",trim(string),rcode + endif + if ( present(rcode) )then + rc = rcode + else + rc = 1001 + end if + call MPI_ABORT(MPI_COMM_WORLD,rc,ierr) + +END SUBROUTINE shr_mpi_abort + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_barrier(comm,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_barrier) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI barrier +!------------------------------------------------------------------------------- + + call MPI_BARRIER(comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_barrier + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_init(string) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_init) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI init +!------------------------------------------------------------------------------- + + call MPI_INIT(ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_init + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_finalize(string) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_finalize) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI finalize +!------------------------------------------------------------------------------- + + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + call MPI_FINALIZE(ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_finalize + +!=============================================================================== +!=============================================================================== + +END MODULE shr_mpi_mod diff --git a/share/csm_share/shr/shr_msg_mod.F90 b/share/csm_share/shr/shr_msg_mod.F90 new file mode 100644 index 000000000000..4ffd0c54512f --- /dev/null +++ b/share/csm_share/shr/shr_msg_mod.F90 @@ -0,0 +1,211 @@ +!=============================================================================== +! SVN $Id: shr_msg_mod.F90 6752 2007-10-04 21:02:15Z jwolfe $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_msg_mod.F90 $ +!=============================================================================== + +!BOP =========================================================================== +! +! !MODULE: shr_msg_mod.F90 --- Module to handle various file utilily functions. +! +! !DESCRIPTION: +! +! Miscilaneous methods to handle file and directory utilities needed for +! message passing CCSM. +! +! NOTE: +! +! This module can be replaced by the direct use of shr_file_mod.F90 as all +! real functionality was moved to shr_file_mod. +! +! !REVISION HISTORY: +! 2006-05-08 E. Kluzek, move functionality to shr_file_mod.F90. +! 2000-??-?? B. Kauffman, original version circa 2000 +! +! !INTERFACE: ------------------------------------------------------------------ + +MODULE shr_msg_mod + +! ! USES: + use shr_file_mod ! The real guts of everything here + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + IMPLICIT none + PRIVATE ! By default everything is private to this module + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + public :: shr_msg_chDir ! change current working directory + public :: shr_msg_chStdIn ! change stdin (attach to a file) + public :: shr_msg_chStdOut ! change stdout (attach to a file) + public :: shr_msg_stdio ! change dir and stdin and stdout + public :: shr_msg_dirio ! change stdin and stdout + +! !PUBLIC DATA MEMBERS: + + ! no public data members + +!EOP + +!=============================================================================== +CONTAINS +!=============================================================================== + +!BOP =========================================================================== +! +! !IROUTINE: shr_msg_stdio -- Change working directory, and redirect stdin/stdout +! +! !DESCRIPTION: +! 1) change the cwd (current working directory) and +! 2) redirect stdin & stdout (units 5 & 6) to named files, +! where the desired cwd & files are specified by namelist file. +! +! !INTERFACE: ------------------------------------------------------------------ +SUBROUTINE shr_msg_stdio(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(len=*),intent(in) :: model ! used to construct env varible name +!EOP + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_stdio(model) + +END SUBROUTINE shr_msg_stdio + +!=============================================================================== + +!BOP =========================================================================== +! +! !IROUTINE: shr_msg_chdir -- Change working directory. +! +! !DESCRIPTION: +! change the cwd (current working directory), see shr_msg_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_msg_chdir(model) + +! !USES: + use shr_sys_mod, only: shr_sys_chdir + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(len=*),intent(in) :: model ! used to construct env varible name +!EOP + + !--- local --- + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_chdir( model ) + +END SUBROUTINE shr_msg_chdir + +!=============================================================================== + +!BOP =========================================================================== +! +! !IROUTINE: shr_msg_dirio --- Change stdin and stdout. +! +! !DESCRIPTION: +! change the stdin & stdout (units 5 & 6), see shr_msg_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ +SUBROUTINE shr_msg_dirio(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(len=*),intent(in) :: model ! used to construct env varible name +!EOP + + !--- local --- + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_dirio(model) + +END SUBROUTINE shr_msg_dirio + +!=============================================================================== + +!BOP =========================================================================== +! +! !IROUTINE: shr_msg_chStdIn -- Change stdin +! +! !DESCRIPTION: +! change the stdin (unit 5), see shr_msg_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ +SUBROUTINE shr_msg_chStdIn(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(*),intent(in) :: model ! used to construct env varible name +!EOP + !--- local --- + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_chStdIn(model) + +END SUBROUTINE shr_msg_chStdIn + +!=============================================================================== + +!BOP =========================================================================== +! +! !IROUTINE: shr_msg_stdout -- Change stdout +! +! !DESCRIPTION: +! change the stdout (unit 6), see shr_msg_stdio for notes +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_msg_chStdOut(model) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + !--- arguments --- + character(*),intent(in) :: model ! used to construct env varible name +!EOP + + !--- local --- + +!------------------------------------------------------------------------------- +! Notes: +! +!------------------------------------------------------------------------------- + + call shr_file_chStdOut(model) + +END SUBROUTINE shr_msg_chStdOut + +!=============================================================================== + +END MODULE shr_msg_mod diff --git a/share/csm_share/shr/shr_ncread_mod.F90 b/share/csm_share/shr/shr_ncread_mod.F90 new file mode 100644 index 000000000000..94a0a7b75566 --- /dev/null +++ b/share/csm_share/shr/shr_ncread_mod.F90 @@ -0,0 +1,1636 @@ +!=============================================================================== +! SVN $Id: shr_ncread_mod.F90 29597 2011-08-04 02:24:04Z erik $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_ncread_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_ncread_mod -- semi-generic netCDF file reader +! +! !DESCRIPTION: +! Reads netcdf stuff off a file +! \newline +! General Usage: +! check = shr_ncread_varExists('myfile','sst') +! call shr_ncread_varDimNum('myfile','sst',ndims) +! call shr_ncread_varDimSize('myfile','sst','lon',nsize) +! call shr_ncread_varDimSize('myfile','sst', 2 ,nsize) +! call shr_ncread_varDimSizes('myfile','sst',ns1,ns2,ns3) +! call shr_ncread_dimSize('myfile','lon',nsize) +! call shr_ncread_domain('myfile','xc',lon,'yc',lat,'mask',imask,'area',area) +! call shr_ncread_tField('myfile',6,'sst',a2d) +! call shr_ncread_tField('myfile',6,'sst',a2d,'xc','yc','time') +! call shr_ncread_tField('myfile',1,'zlev',a1d) +! call shr_ncread_field4dG('myfile','sst',rfld=a4d) +! call shr_ncread_field4dG('myfile','sst',rfld=a4d,dim1='lon',dim2='lat',dim3='time',dim3i=21) +! call shr_ncread_setAbort(.true.) +! call shr_ncread_setDebug(1) +! \newline +! +! !REVISION HISTORY: +! 2005-May-15 - T. Craig - first version +! 2005-Apr-21 - B. Kauffman, J. Schramm, M. Vertenstein - first design +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_ncread_mod + +! !USES: + + use shr_string_mod ! string methods + use shr_kind_mod ! kinds + use shr_sys_mod ! shared system calls + use shr_file_mod ! file methods + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use netcdf + + implicit none + + private ! everything is default private + +! !PUBLIC TYPES: + + ! no public data types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_ncread_varExists + public :: shr_ncread_varDimNum + public :: shr_ncread_varDimSize + public :: shr_ncread_varDimSizes + public :: shr_ncread_dimSize + public :: shr_ncread_domain + public :: shr_ncread_tField + public :: shr_ncread_Field4dG + public :: shr_ncread_handleErr + public :: shr_ncread_setAbort + public :: shr_ncread_setDebug + public :: shr_ncread_open + public :: shr_ncread_close + +! !PUBLIC DATA MEMBERS: + + ! no public data members + +!EOP + + interface shr_ncread_varDimSize ; module procedure & + shr_ncread_varDimSizeName, & + shr_ncread_varDimSizeID + end interface + + interface shr_ncread_dimSize ; module procedure & + shr_ncread_dimSizeName + end interface + + interface shr_ncread_tField ; module procedure & + shr_ncread_tField2dR8, & + shr_ncread_tField1dR8, & + shr_ncread_tField2dIN, & + shr_ncread_tField1dIN + end interface + + logical ,save :: doabort = .true. + integer(SHR_KIND_IN),save :: debug = 0 + +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_varExists -- return logical for existance of var +! +! !DESCRIPTION: +! Return logical if variable name exists on file +! \newline +! General Usage: +! check = shr_ncread_varExists('myfile','sst') +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_ncread_varExists(fileName, varName) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: fileName ! nc file name + character(*),intent(in) :: varName ! name of variable + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: fid + integer(SHR_KIND_IN) :: vid + integer(SHR_KIND_IN) :: debug0 + integer(SHR_KIND_IN) :: rCode + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_varExists)" + character(*),parameter :: F00 = "('(shr_ncread_varExists) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_varExists) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--- turn off debug writing --- + debug0 = debug + call shr_ncread_setDebug(0) + + shr_ncread_varExists = .false. + call shr_ncread_open(fileName,fid,rCode) + rcode = nf90_inq_varid(fid,trim(varName),vid) + if (rcode == nf90_noerr) shr_ncread_varExists = .true. + call shr_ncread_close(fid,rCode) + + !--- reset debug code --- + call shr_ncread_setDebug(debug0) + +end function shr_ncread_varExists +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_varDimNum -- return num of dimensions of a variable +! +! !DESCRIPTION: +! Returns the number of dimensions of a named variable +! \newline +! General Usage: +! call shr_ncread_varDimNum('myfile','sst',ndims) +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_varDimNum(fileName, varName, ns, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fileName ! nc file name + character(*) ,intent(in) :: varName ! name of variable + integer(SHR_KIND_IN),intent(out) :: ns ! number of dims of var + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: fid + integer(SHR_KIND_IN) :: vid + integer(SHR_KIND_IN) :: rCode + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_varDimNum)" + character(*),parameter :: F00 = "('(shr_ncread_varDimNum) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_varDimNum) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_ncread_open(fileName,fid,rCode) + + !--- read variable info --- + rcode = nf90_inq_varid(fid,trim(varName),vid) + call shr_ncread_handleErr(rCode, subName//" ERROR inq varid") + rcode = nf90_inquire_variable(fid,vid,ndims=ns) + call shr_ncread_handleErr(rCode, subName//" ERROR inq var") + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) trim(varName)//' has dims = ',ns + + call shr_ncread_close(fid,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_varDimNum +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_varDimSizeName -- return var dim size by dim name +! +! !DESCRIPTION: +! Returns the size of a dimension of a variable, both dimension and +! variable are named. +! \newline +! General Usage: +! call shr_ncread_varDimSize('myfile','sst','lon',nsize) +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_varDimSizeName(fileName, varName, dimName, ns, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fileName ! nc file name + character(*) ,intent(in) :: varName ! name of variable + character(*) ,intent(in) :: dimName ! name of dimension + integer(SHR_KIND_IN),intent(out) :: ns ! number of dims of var + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_varDimSizeName)" + character(*),parameter :: F00 = "('(shr_ncread_varDimSizeName) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_varDimSizeName) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_ncread_dimSizeName(fileName,dimName,ns,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_varDimSizeName +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_varDimSizeID -- return var dim size by dim number +! +! !DESCRIPTION: +! Returns the size of a dimension of a variable where the variable is +! named and the dimension is numbered. +! \newline +! General Usage: +! call shr_ncread_varDimSize('myfile','sst',2,nsize) +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_varDimSizeID(fileName, varName, dnum, ns, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fileName ! nc file name + character(*) ,intent(in) :: varName ! name of variable + integer(SHR_KIND_IN),intent(in) :: dnum ! dim number in var + integer(SHR_KIND_IN),intent(out) :: ns ! size of dim in var + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: fid ! file id + integer(SHR_KIND_IN) :: vid ! var id + integer(SHR_KIND_IN) :: ndims ! number of dims + character(SHR_KIND_CS) :: dimName ! dim name + integer(SHR_KIND_IN),allocatable :: dids(:) ! dim ids + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_varDimSizeID)" + character(*),parameter :: F00 = "('(shr_ncread_varDimSizeID) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_varDimSizeID) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_ncread_open(fileName,fid,rCode) + + rCode = nf90_inq_varid(fid,trim(varName),vid) + call shr_ncread_handleErr(rCode,subName//' ERROR inq varid vid') + rCode = nf90_inquire_variable(fid,vid,ndims=ndims) + call shr_ncread_handleErr(rCode,subName//' ERROR inquire variable ndims') + allocate(dids(ndims)) + rCode = nf90_inquire_variable(fid,vid,dimids=dids) + call shr_ncread_handleErr(rCode,subName//' ERROR inquire variable dimids') + rcode = nf90_inquire_dimension(fid,dids(dnum),name=dimName,len=ns) + call shr_ncread_handleErr(rCode, subName//" ERROR inquire dimension") + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) trim(dimName)//' dimension has size = ',ns + + deallocate(dids) + call shr_ncread_close(fid,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_varDimSizeID +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_varDimSizes -- return var dim sizes +! +! !DESCRIPTION: +! Returns the dimension sizes of a named variable using optional arguments. +! Each optional argument represents a numbered dimension. +! /newline +! General Usage: +! call shr_ncread_varDimSizes('myfile','sst',ns1,ns2,ns3) +! /newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_varDimSizes(fileName, varName, n1, n2, n3, n4, n5, n6, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fileName ! nc file name + character(*) ,intent(in) :: varName ! name of variable + integer(SHR_KIND_IN),intent(out),optional :: n1 ! size of dim1 in var + integer(SHR_KIND_IN),intent(out),optional :: n2 ! size of dim2 in var + integer(SHR_KIND_IN),intent(out),optional :: n3 ! size of dim3 in var + integer(SHR_KIND_IN),intent(out),optional :: n4 ! size of dim4 in var + integer(SHR_KIND_IN),intent(out),optional :: n5 ! size of dim5 in var + integer(SHR_KIND_IN),intent(out),optional :: n6 ! size of dim6 in var + Integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN),parameter :: maxn = 6 ! max number of dims available + integer(SHR_KIND_IN) :: n ! counter + integer(SHR_KIND_IN) :: fid ! file id + integer(SHR_KIND_IN) :: vid ! variable id + integer(SHR_KIND_IN) :: ndims ! number of dims + integer(SHR_KIND_IN),allocatable :: dids(:) ! dimids + integer(SHR_KIND_IN),allocatable :: ns(:) ! size of dims + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_varDimSizes)" + character(*),parameter :: F00 = "('(shr_ncread_varDimSizes) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_varDimSizes) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_ncread_open(fileName,fid,rCode) + + rCode = nf90_inq_varid(fid,trim(varName),vid) + call shr_ncread_handleErr(rCode,subName//' ERROR inq varid vid') + rCode = nf90_inquire_variable(fid,vid,ndims=ndims) + call shr_ncread_handleErr(rCode,subName//' ERROR inquire variable ndims') + allocate(dids(ndims)) + allocate(ns(maxn)) + rCode = nf90_inquire_variable(fid,vid,dimids=dids) + call shr_ncread_handleErr(rCode,subName//' ERROR inquire variable dimids') + + !--- get dim sizes for all dims or to maxn, default result is 1 --- + ns = 1 + do n=1,min(ndims,maxn) + rcode = nf90_inquire_dimension(fid,dids(n),len=ns(n)) + call shr_ncread_handleErr(rCode, subName//" ERROR inquire dimension") + enddo + + call shr_ncread_close(fid,rCode) + + !--- copy to output optional arguments --- + if (present(n1)) then + n1 = ns(1) + endif + if (present(n2)) then + n2 = ns(2) + endif + if (present(n3)) then + n3 = ns(3) + endif + if (present(n4)) then + n4 = ns(4) + endif + if (present(n5)) then + n5 = ns(5) + endif + if (present(n6)) then + n6 = ns(6) + endif + + deallocate(dids) + deallocate(ns) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_varDimSizes +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_dimSizeName -- return size of dimension +! +! !DESCRIPTION: +! Returns the size of a named dimension +! \newline +! General Usage: +! call shr_ncread_dimSize('myfile','lon',nsize) +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_dimSizeName(fileName, dimName, ns, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fileName ! nc file name + character(*) ,intent(in) :: dimName ! name of dimension + integer(SHR_KIND_IN),intent(out) :: ns ! size of dimension + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: fid ! file id + integer(SHR_KIND_IN) :: did ! dim id + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_dimSizeName)" + character(*),parameter :: F00 = "('(shr_ncread_dimSizeName) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_dimSizeName) ',a,i6)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_ncread_open(fileName,fid,rCode) + + !--- read coordinate dimensions --- + rcode = nf90_inq_dimid (fid, trim(dimName), did) ! size of dimension + call shr_ncread_handleErr(rCode, subName//" ERROR inq dimid") + rcode = nf90_inquire_dimension(fid,did,len=ns) + call shr_ncread_handleErr(rCode, subName//" ERROR inquire dimension") + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F01) trim(dimName)//' dimension has size = ',ns + + call shr_ncread_close(fid,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_dimSizeName +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_domain -- read in domain info from a file +! +! !DESCRIPTION: +! Read in domain information from a file. The subroutine is designed +! specially for certain criteria in CCSM. longitude, latitude, mask, +! a area arrays will be read in from the cdf file for each variable +! name input. Across the subroutine interface, all arrays are 2d, +! and each is real*8 except mask which is an integer array. Within +! the netcdf file, other scenarios are possible. +! note: +! o always returns 2d lat/lon arrays even if data is 1d in netCDF file +! o works if lat & lon are dimensions or variables +! o assumes area and mask are variables without a time dimension +! o mask is an integer array, all others are real*8 +! o mask is read as real*8 array then copied via nint +! o assumes arrays are already allocated by the caller +! +! \newline +! General Usage: +! call shr_ncread_domain('myfile','xc',lon,'yc',lat,'mask',imask,'area',area) +! \newline +! !REVISION HISTORY: +! 2005-Apr-21 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_domain(fn, lonName, lon, latName, lat, & + & maskName, mask, areaName, area, & + & fracName, frac, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + character(*) ,intent(in) :: lonName ! name of longitude var + real(SHR_KIND_R8) ,intent(out) :: lon(:,:) ! longitudes + character(*) ,intent(in) :: latName ! name of latitude var + real(SHR_KIND_R8) ,intent(out) :: lat(:,:) ! latitudes + character(*) ,intent(in) ,optional:: maskName ! name of mask var + integer(SHR_KIND_IN),intent(out),optional:: mask(:,:) ! domain mask + character(*) ,intent(in) ,optional:: areaName ! name of area var + real(SHR_KIND_R8) ,intent(out),optional:: area(:,:) ! cell area + character(*) ,intent(in) ,optional:: fracName ! name of frac var + real(SHR_KIND_R8) ,intent(out),optional:: frac(:,:) ! cell frac + integer(SHR_KIND_IN),intent(out),optional:: rc ! return code + +!EOP + !----- local ----- + real(SHR_KIND_R8),allocatable :: A4d(:,:,:,:) ! local 4d array + real(SHR_KIND_R8),allocatable :: P2d(:,:) ! pointer to 2d arrays + character(SHR_KIND_CS) :: varName ! var name + integer(SHR_KIND_IN) :: nflds ! number of flds to read + integer(SHR_KIND_IN) :: n,i,j ! counters + integer(SHR_KIND_IN) :: ndim,nd1,nd2 ! dims and size of 2 dims for cdf field + integer(SHR_KIND_IN) :: pd1,pd2 ! size of 2 dims for P2d + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_domain)" + character(*),parameter :: F00 = "('(shr_ncread_domain) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_domain) ',2a,3i6,2x,a)" + character(*),parameter :: F02 = "('(shr_ncread_domain) ',a,i6)" + character(*),parameter :: F03 = "('(shr_ncread_domain) ',a,2i6)" + character(*),parameter :: F04 = "('(shr_ncread_domain) ',a,2g17.8)" + + logical :: readmask + logical :: readarea + logical :: readfrac +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + rCode = 0 + + nflds = 2 ! manditory fields + + if (present(maskName).and.present(mask)) then + nflds = nflds + 1 + else if (( present(maskName) .and. .not.present(mask)) .or. & + (.not.present(maskName) .and. present(mask))) then + write(s_logunit,F00) ' ERROR: maskName and mask must both be present or not ' + call shr_ncread_abort(subName//' ERROR subroutine arguments, mask') + end if + + if (present(areaName).and.present(area)) then + nflds = nflds + 1 + else if (( present(areaName) .and. .not.present(area)) .or. & + (.not.present(areaName) .and. present(area))) then + write(s_logunit,F00) ' ERROR: areaName and area must both be present or not ' + call shr_ncread_abort(subName//' ERROR subroutine arguments, area') + end if + + if (present(fracName).and.present(frac)) then + nflds = nflds + 1 + else if (( present(fracName) .and. .not.present(frac)) .or. & + (.not.present(fracName) .and. present(frac))) then + write(s_logunit,F00) ' ERROR: fracName and frac must both be present or not ' + call shr_ncread_abort(subName//' ERROR subroutine arguments, frac') + end if + + ! --- two fields hardwired --- + readmask = .true. + readarea = .true. + readfrac = .true. + do n=1,nflds + if (n == 1) then + varName = trim(lonName) + allocate(P2d(size(lon,1),size(lon,2))) + elseif (n == 2) then + varName = trim(latName) + allocate(P2d(size(lat,1),size(lat,2))) + elseif (n > 2) then + if (present(maskName) .and. readmask) then + varName = trim(maskName) + !--- since mask in an integer, allocate P2d and copy back later --- + allocate(P2d(size(mask,1),size(mask,2))) + readmask = .false. + else if (present(areaName) .and. readarea) then + varName = trim(areaName) + allocate(P2d(size(area,1),size(area,2))) + readarea = .false. + else if (present(fracName) .and. readfrac) then + varName = trim(fracName) + allocate(P2d(size(frac,1),size(frac,2))) + readfrac = .false. + endif + end if + + if (.not.shr_ncread_varExists(fn,varName)) & + call shr_ncread_abort(subName//' ERROR var does not exist '//trim(varName)) + + !--- get size of input array --- + pd1 = size(P2d,1) + pd2 = size(P2d,2) + + !--- get var dims and check --- + call shr_ncread_varDimNum(fn,varName,ndim) + if (n > 2 .and. ndim /= 2) then + write(s_logunit,F02) 'ERROR '//trim(varName)//' ndim = ',ndim + call shr_ncread_abort(subName//' ERROR ndim must be 2 for '//trim(varName)) + elseif (ndim < 1 .or. ndim > 2) then + write(s_logunit,F02) 'ERROR '//trim(varName)//' ndim = ',ndim + call shr_ncread_abort(subName//' ERROR ndim must be 1 or 2 for '//trim(varName)) + endif + nd1 = 1 + nd2 = 1 + if (ndim > 0) call shr_ncread_varDimSize(fn,varName,1,nd1) + if (ndim > 1) call shr_ncread_varDimSize(fn,varName,2,nd2) + + !--- error check dimensions, special case for 1d lat --- + if (n == 2 .and. ndim == 1) then + if ( nd1 /= pd2) then + write(s_logunit,F03) ' nd1 pd2 error ',nd1,pd2 + call shr_ncread_abort(subName//' ERROR nd1 pd2 error') + endif + elseif (ndim > 0 .and. nd1 /= pd1) then + write(s_logunit,F03) ' nd1 pd1 error ',nd1,pd1 + call shr_ncread_abort(subName//' ERROR nd1 pd1 error') + endif + if (ndim > 1 .and. nd2 /= pd2) then + write(s_logunit,F03) ' nd2 pd2 error ',nd2,pd2 + call shr_ncread_abort(subName//' ERROR nd2 pd2 error') + endif + + !--- allocate A4d and read --- + allocate(A4d(nd1,nd2,1,1)) + A4d = 0.0_SHR_KIND_R8 + call shr_ncread_field4dG(fn,varName,rfld=A4d) + + !--- copy into P2d as appropriate --- + do j = 1,pd2 + do i = 1,pd1 + if (n == 2 .and. ndim == 1) then + P2d(i,j) = A4d(j,1,1,1) + elseif (ndim == 1) then + P2d(i,j) = A4d(i,1,1,1) + else + P2d(i,j) = A4d(i,j,1,1) + endif + enddo + enddo + + !--- copy into mask R8 to IN --- + if (n == 1) then + lon(:,:) = P2d(:,:) + elseif (n == 2) then + lat(:,:) = P2d(:,:) + elseif (n == 3) then + mask(:,:) = nint(P2d(:,:)) + elseif (n == 4) then + area(:,:) = P2d(:,:) + elseif (n == 5) then + frac(:,:) = P2d(:,:) + endif + + !--- clean up --- + deallocate(A4d) + deallocate(P2d,stat=rCode) +! nullify(P2d) + + enddo + + if (debug > 1 .and. s_loglev > 0) then + write(s_logunit,F04) 'min/max lon ',minval(lon),maxval(lon) + write(s_logunit,F04) 'min/max lat ',minval(lat),maxval(lat) + write(s_logunit,F04) 'min/max mask ',minval(mask),maxval(mask) + write(s_logunit,F04) 'min/max area ',minval(area),maxval(area) + if (nflds >= 5 .and. s_loglev > 0) write(s_logunit,F04) 'min/max frac ',minval(frac),maxval(frac) + endif + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_domain +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_tField2dR8 -- read in field data from a file +! +! !DESCRIPTION: +! Read in field data from a netcdf file. This is a special routine +! built specificallly for CCSM. The idea is to read a snapshot of +! (possibly) time-varying data from a netcdf file. The array is a +! 2d real*8 field in this case. Inputs are filename, timeslice +! (integer), and variable name. Optional inputs include the +! time dimension name and the 2 dimension names for the array. +! If dim1 is sent as an optional argument, dim2 must also be sent. +! Otherwise, the time dimension is assumed to be the third +! dimension and the first 2 dimensions are associated with the +! 2d array. +! +! \newline +! General Usage: +! call shr_ncread_tField('myfile',6,'sst',a2d) +! \newline +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_tField2dR8(fn, tIndex, fldName, fld, dim1, dim2, tName, fidi, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + integer(SHR_KIND_IN),intent(in) :: tIndex ! time-coord index + character(*) ,intent(in) :: fldName ! name of field + real(SHR_KIND_R8) ,intent(out) :: fld(:,:) ! field array + character(*) ,intent(in) ,optional :: dim1 ! name of dim1 in fld + character(*) ,intent(in) ,optional :: dim2 ! name of dim2 in fld + character(*) ,intent(in) ,optional :: tName ! name of tIndex dim + integer(SHR_KIND_IN),intent(in) ,optional :: fidi ! file id + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + real(SHR_KIND_R8),allocatable :: lfld(:,:,:,:) ! local 4d array + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_tField2dR8)" + character(*),parameter :: F00 = "('(shr_ncread_tField2dR8) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + allocate(lfld(size(fld,1),size(fld,2),1,1)) + + if (present(dim1).and.present(dim2).and.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=dim2,dim3=tName,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=dim2,dim3=tName,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(dim1).and.present(dim2)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=dim2,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=dim2,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim3=tName,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim3=tName,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (.not.present(dim1).and..not.present(dim2).and..not.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + else + call shr_ncread_abort(subName//' ERROR argument combination not supported') + endif + + fld(:,:) = lfld(:,:,1,1) + deallocate(lfld) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_tField2dR8 +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_tField1dR8 -- read in field data from a file +! +! !DESCRIPTION: +! Read in field data from a netcdf file. This is a special routine +! built specificallly for CCSM. The idea is to read a snapshot of +! (possibly) time-varying data from a netcdf file. The array is a +! 1d real*8 field in this case. Inputs are filename, timeslice +! (integer), and variable name. Optional inputs include the +! time dimension name and the dimension name for the array. +! Otherwise, the time dimension is assumed to be the second +! dimension and the first dimension is associated with the +! 1d array. +! \newline +! General Usage: +! call shr_ncread_tField('myfile',1,'zlev',a1d) +! \newline +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_tField1dR8(fn, tIndex, fldName, fld, dim1, tName, fidi, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + integer(SHR_KIND_IN),intent(in) :: tIndex ! time-coord index + character(*) ,intent(in) :: fldName ! name of field + real(SHR_KIND_R8) ,intent(out) :: fld(:) ! field array + character(*) ,intent(in) ,optional :: dim1 ! name of dim1 in fld + character(*) ,intent(in) ,optional :: tName ! name of tIndex dim + integer(SHR_KIND_IN),intent(in) ,optional :: fidi ! file id + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + real(SHR_KIND_R8),allocatable :: lfld(:,:,:,:) ! local 4d array + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_tField1dR8)" + character(*),parameter :: F00 = "('(shr_ncread_tField1dR8) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + allocate(lfld(size(fld,1),1,1,1)) + + if (present(dim1).and.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=tName,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2=tName,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(dim1)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim1=dim1,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim2=tName,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim2=tName,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (.not.present(dim1).and..not.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,rfld=lfld,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + else + call shr_ncread_abort(subName//' ERROR argument combination not supported') + endif + + fld(:) = lfld(:,1,1,1) + deallocate(lfld) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_tField1dR8 +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_tField2dIN -- read in field data from a file +! +! !DESCRIPTION: +! Read in field data from a netcdf file. This is a special routine +! built specificallly for CCSM. The idea is to read a snapshot of +! (possibly) time-varying data from a netcdf file. The array is a +! 2d integer field in this case. Inputs are filename, timeslice +! (integer), and variable name. Optional inputs include the +! time dimension name and the 2 dimension names for the array. +! If dim1 is sent as an optional argument, dim2 must also be sent. +! Otherwise, the time dimension is assumed to be the third +! dimension and the first 2 dimensions are associated with the +! 2d array. +! +! \newline +! General Usage: +! call shr_ncread_tField('myfile',1,'index',i2d) +! \newline +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_tField2dIN(fn, tIndex, fldName, fld, dim1, dim2, tName, fidi, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + integer(SHR_KIND_IN),intent(in) :: tIndex ! time-coord index + character(*) ,intent(in) :: fldName ! name of field + integer(SHR_KIND_IN),intent(out) :: fld(:,:) ! field array + character(*) ,intent(in) ,optional :: dim1 ! name of dim1 in fld + character(*) ,intent(in) ,optional :: dim2 ! name of dim2 in fld + character(*) ,intent(in) ,optional :: tName ! name of tIndex dim + integer(SHR_KIND_IN),intent(in) ,optional :: fidi ! file id + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN),allocatable :: lfld(:,:,:,:) ! local 4d array + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_tField2dIN)" + character(*),parameter :: F00 = "('(shr_ncread_tField2dIN) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + allocate(lfld(size(fld,1),size(fld,2),1,1)) + + if (present(dim1).and.present(dim2).and.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=dim2,dim3=tName,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=dim2,dim3=tName,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(dim1).and.present(dim2)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=dim2,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=dim2,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim3=tName,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim3=tName,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (.not.present(dim1).and..not.present(dim2).and..not.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim3i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim3i=tIndex,fidi=fidi,rc=rCode) + endif + else + call shr_ncread_abort(subName//' ERROR argument combination not supported') + endif + + fld(:,:) = lfld(:,:,1,1) + deallocate(lfld) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_tField2dIN +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_tField1dIN -- read in field data from a file +! +! !DESCRIPTION: +! Read in field data from a netcdf file. This is a special routine +! built specificallly for CCSM. The idea is to read a snapshot of +! (possibly) time-varying data from a netcdf file. The array is a +! 1d integer field in this case. Inputs are filename, timeslice +! (integer), and variable name. Optional inputs include the +! time dimension name and the dimension name for the array. +! Otherwise, the time dimension is assumed to be the second +! dimension and the first dimension is associated with the +! 1d array. +! \newline +! General Usage: +! call shr_ncread_tField('myfile',1,'klev',a1d) +! \newline +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_tField1dIN(fn, tIndex, fldName, fld, dim1, tName, fidi, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + integer(SHR_KIND_IN),intent(in) :: tIndex ! time-coord index + character(*) ,intent(in) :: fldName ! name of field + integer(SHR_KIND_IN),intent(out) :: fld(:) ! field array + character(*) ,intent(in) ,optional :: dim1 ! name of dim1 in fld + character(*) ,intent(in) ,optional :: tName ! name of tIndex dim + integer(SHR_KIND_IN),intent(in) ,optional :: fidi ! file id + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN),allocatable :: lfld(:,:,:,:) ! local 4d array + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_tField1dIN)" + character(*),parameter :: F00 = "('(shr_ncread_tField1dIN) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + allocate(lfld(size(fld,1),1,1,1)) + + if (present(dim1).and.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=tName,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2=tName,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(dim1)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim1=dim1,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim2=tName,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim2=tName,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + elseif (.not.present(dim1).and..not.present(tName)) then + if (.not.present(fidi)) then + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim2i=tIndex,rc=rCode) + else + call shr_ncread_field4dG(fn,fldName,ifld=lfld,dim2i=tIndex,fidi=fidi,rc=rCode) + endif + else + call shr_ncread_abort(subName//' ERROR argument combination not supported') + endif + + fld(:) = lfld(:,1,1,1) + deallocate(lfld) + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_tField1dIN +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_field4dG -- read in field data from a file +! +! !DESCRIPTION: +! Read in field data from a cdf file, fld is 4d in this case +! This subroutine supports the reading of 1d, 2d, 3d, or 4d +! data through the interface as long as the calling argument +! is explicitly 4d. The user may need to invoke a temporary +! 4d pointer or array to use this subroutine. +! Can read in a subset of data from a netcdf file that's up +! to 6 dimensions large. +! Supports real*8 and integer arrays, must specify either rfld +! or ifld in optional arguments +! dimN are the dimension names associated with the 4d input array, +! if N>4, this represents dimensions outside a 4d array which can +! be optionally set to a specific index using dimNi +! dimNi set the index to be used for the dimn dimension name +! +! \newline +! General Usage: +! call shr_ncread_field4dG('myfile','sst',rfld=a4d) +! call shr_ncread_field4dG('myfile','sst',rfld=a4d,dim1='lon',dim2='lat',dim3='time',dim3i=21) +! call shr_ncread_field4dG('myfile','tracer',rfld=a4d,dim5='tracer_n',dim5i=3) +! \newline +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_field4dG(fn, fldName, rfld, ifld, & + dim1, dim1i, dim2, dim2i, dim3, dim3i, dim4, dim4i, & + dim5, dim5i, dim6, dim6i, fidi, rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: fn ! nc file name + character(*) ,intent(in) :: fldName ! name of field + real(SHR_KIND_R8) ,intent(out),optional :: rfld(:,:,:,:) ! field array + integer(SHR_KIND_IN),intent(out),optional :: ifld(:,:,:,:) ! field array + character(*) ,intent(in) ,optional :: dim1 ! name of dim1 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim1i ! dim1 index + character(*) ,intent(in) ,optional :: dim2 ! name of dim2 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim2i ! dim2 index + character(*) ,intent(in) ,optional :: dim3 ! name of dim3 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim3i ! dim3 index + character(*) ,intent(in) ,optional :: dim4 ! name of dim4 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim4i ! dim4 index + character(*) ,intent(in) ,optional :: dim5 ! name of dim5 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim5i ! dim5 index + character(*) ,intent(in) ,optional :: dim6 ! name of dim6 in fld + integer(SHR_KIND_IN),intent(in) ,optional :: dim6i ! dim6 index + integer(SHR_KIND_IN),intent(in) ,optional :: fidi ! file id + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + !----- local ----- + integer(SHR_KIND_IN),parameter :: maxd = 4 ! max num of dims of array + integer(SHR_KIND_IN) :: fid ! file id + integer(SHR_KIND_IN) :: vid ! var id + integer(SHR_KIND_IN) :: xtype ! var type + integer(SHR_KIND_IN) :: ndims ! number of dims + integer(SHR_KIND_IN) :: n,n1,n2,n3,n4,k ! counters + integer(SHR_KIND_IN) ,allocatable :: dimid(:) ! dimension ids for array + integer(SHR_KIND_IN) ,allocatable :: dids(:) ! dimension ids for cdf + integer(SHR_KIND_IN) ,allocatable :: start(:) ! cdf start array + integer(SHR_KIND_IN) ,allocatable :: count(:) ! cdf count array + integer(SHR_KIND_IN) ,allocatable :: len(:) ! size of dim + character(SHR_KIND_CS),allocatable :: name(:) ! name of dim + real(SHR_KIND_R8) ,allocatable :: rin(:,:) ! local 2d array + integer(SHR_KIND_IN) ,allocatable :: iin(:,:) ! local 2d array + integer(SHR_KIND_IN) ,allocatable :: start2d(:) ! start for 2d local array + integer(SHR_KIND_IN) ,allocatable :: count2d(:) ! count for 2d local array + logical :: found ! search logical + integer(SHR_KIND_IN) :: rCode ! error code + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_field4dG) " + character(*),parameter :: F00 = "('(shr_ncread_field4dG) ',4a)" + character(*),parameter :: F01 = "('(shr_ncread_field4dG) ',2a,3i6,2x,a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--- check that rfld or ifld is present --- + if (present(rfld).and.present(ifld)) then + call shr_ncread_abort(subName//'both rfld and ifld should not be sent') + endif + if (.not.present(rfld).and..not.present(ifld)) then + call shr_ncread_abort(subName//'either rfld or ifld must be sent') + endif + + if (.not.present(fidi)) then + call shr_ncread_open(fn,fid,rCode) + else + fid = fidi + endif + + !--- get variable id and ndims for vid + rCode = nf90_inq_varid(fid,trim(fldName),vid) + call shr_ncread_handleErr(rCode,subName//'inq varid vid: '//trim(fldName)) + rCode = nf90_inquire_variable(fid,vid,xtype=xtype,ndims=ndims) + call shr_ncread_handleErr(rCode,subName//'inquire variable ndims: '//trim(fldName)) + + !--- allocate locals + n4 = max(ndims,maxd) + allocate(dimid (n4)) ; dimid = 0 + allocate(dids (n4)) ; dids = 0 + allocate(name (n4)) ; name = ' ' + allocate(len (n4)) ; len = 1 + allocate(start (n4)) ; start = 1 + allocate(count (n4)) ; count = 1 + allocate(start2d(n4)) ; start2d = 1 + allocate(count2d(n4)) ; count2d = 1 + + !--- get dimension info for vid + rCode = nf90_inquire_variable(fid,vid,dimids=dids) + call shr_ncread_handleErr(rCode,subName//'inquire variable dids: '//trim(fldName)) + do n=1,ndims + rCode = nf90_inquire_dimension(fid,dids(n),name=name(n),len=len(n)) + call shr_ncread_handleErr(rCode,subName//'inquire dimension len: '//trim(fldName)) + enddo + + !--- set dimid from dim + if (present(dim1)) then + do n=1,ndims + if (trim(dim1) == trim(name(n))) dimid(1) = n + enddo + endif + if (present(dim2)) then + do n=1,ndims + if (trim(dim2) == trim(name(n))) dimid(2) = n + enddo + endif + if (present(dim3)) then + do n=1,ndims + if (trim(dim3) == trim(name(n))) dimid(3) = n + enddo + endif + if (present(dim4)) then + do n=1,ndims + if (trim(dim4) == trim(name(n))) dimid(4) = n + enddo + endif + if (present(dim5)) then + do n=1,ndims + if (trim(dim5) == trim(name(n))) dimid(5) = n + enddo + endif + if (present(dim6)) then + do n=1,ndims + if (trim(dim6) == trim(name(n))) dimid(6) = n + enddo + endif + + !--- set dimid for non user set dimension based on what's left + do n1=1,max(maxd,ndims) + k = 1 + do while (dimid(n1) == 0) + found = .false. + do n2 = 1,maxd + if (dimid(n2) == k) found = .true. + enddo + if (found) then + k = k + 1 + else + dimid(n1) = k + endif + enddo + enddo + + !--- set count to len if n exists in variable, otherwise set to 1 + do n1=1,maxd + if (dimid(n1) <= ndims) then + count(dimid(n1)) = len(dimid(n1)) + else + count(dimid(n1)) = 1 + endif + enddo + + !--- modify start and count from user inputs + if (present(dim1i)) then + if (dim1i < 1 .or. dim1i > len(dimid(1))) & + call shr_ncread_abort(subName//'dim1i setting: '//trim(fldName)) + start(dimid(1)) = dim1i + count(dimid(1)) = 1 + endif + if (present(dim2i)) then + if (dim2i < 1 .or. dim2i > len(dimid(2))) & + call shr_ncread_abort(subName//'dim2i setting: '//trim(fldName)) + start(dimid(2)) = dim2i + count(dimid(2)) = 1 + endif + if (present(dim3i)) then + if (dim3i < 1 .or. dim3i > len(dimid(3))) & + call shr_ncread_abort(subName//'dim3i setting: '//trim(fldName)) + start(dimid(3)) = dim3i + count(dimid(3)) = 1 + endif + if (present(dim4i)) then + if (dim4i < 1 .or. dim4i > len(dimid(4))) & + call shr_ncread_abort(subName//'dim4i setting: '//trim(fldName)) + start(dimid(4)) = dim4i + count(dimid(4)) = 1 + endif + if (present(dim5i)) then + if (dim5i < 1 .or. dim5i > len(dimid(5))) & + call shr_ncread_abort(subName//'dim5i setting: '//trim(fldName)) + start(dimid(5)) = dim5i + count(dimid(5)) = 1 + endif + if (present(dim6i)) then + if (dim6i < 1 .or. dim6i > len(dimid(6))) & + call shr_ncread_abort(subName//'dim6i setting: '//trim(fldName)) + start(dimid(6)) = dim6i + count(dimid(6)) = 1 + endif + + !--- error check, fld size must match variable size + do n=1,maxd + if (present(rfld)) then + if (size(rfld,n) /= count(dimid(n))) then + call shr_ncread_abort(subName//'fld size does not agree with count: '//trim(fldName)) + endif + endif + if (present(ifld)) then + if (size(ifld,n) /= count(dimid(n))) then + call shr_ncread_abort(subName//'fld size does not agree with count: '//trim(fldName)) + endif + endif + enddo + + !--- fill fld, prepare both int and real arrays, just in case + !--- use rin/iin and transpose if needed + if (dimid(1) > dimid(2)) then + allocate(rin(count(dimid(2)),count(dimid(1)))) + allocate(iin(count(dimid(2)),count(dimid(1)))) + else + allocate(rin(count(dimid(1)),count(dimid(2)))) + allocate(iin(count(dimid(1)),count(dimid(2)))) + endif + start2d = start + count2d = count + count2d(dimid(3)) = 1 + count2d(dimid(4)) = 1 + do n4 = 1,count(dimid(4)) + do n3 = 1,count(dimid(3)) + start2d(dimid(3)) = n3 + start(dimid(3)) - 1 + start2d(dimid(4)) = n4 + start(dimid(4)) - 1 + if (present(rfld)) then + rCode = nf90_get_var(fid,vid,rin,start=start2d,count=count2d) + elseif (present(ifld)) then + rCode = nf90_get_var(fid,vid,iin,start=start2d,count=count2d) + endif + call shr_ncread_handleErr(rCode,subName//'get var: '//trim(fldName)) + +! if (debug > 1 .and. s_loglev > 0) then +! write(s_logunit,*) subName,' size rfld',size(rfld,1),size(rfld,2), & +! size(rfld,3),size(rfld,4) +! write(s_logunit,*) subName,' size ifld',size(ifld,1),size(ifld,2), & +! size(ifld,3),size(ifld,4) +! write(s_logunit,*) subName,' size rin',size(rin,1),size(rin,2) +! write(s_logunit,*) subName,' size iin',size(iin,1),size(iin,2) +! write(s_logunit,*) subName,' dimid ',dimid +! write(s_logunit,*) subName,' start ',start +! write(s_logunit,*) subName,' count ',count +! write(s_logunit,*) subName,' start2d ',start2d +! write(s_logunit,*) subName,' count2d ',count2d +! write(s_logunit,*) subName,' min/max rin ',minval(rin),maxval(rin) +! write(s_logunit,*) subName,' min/max iin ',minval(iin),maxval(iin) +! endif + do n2 = 1,count(dimid(2)) + do n1 = 1,count(dimid(1)) + if (dimid(1) > dimid(2)) then + if (present(rfld)) then + rfld(n1,n2,n3,n4) = rin(n2,n1) + elseif (present(ifld)) then + ifld(n1,n2,n3,n4) = iin(n2,n1) + endif + else + if (present(rfld)) then + rfld(n1,n2,n3,n4) = rin(n1,n2) + elseif (present(ifld)) then + ifld(n1,n2,n3,n4) = iin(n1,n2) + endif + endif + enddo + enddo + enddo + enddo + deallocate(rin) + deallocate(iin) + + deallocate(dimid) + deallocate(dids) + deallocate(start) + deallocate(count) + deallocate(name) + deallocate(len) + deallocate(start2d) + deallocate(count2d) + if (.not.present(fidi)) then + call shr_ncread_close(fid,rCode) + endif + + if (present(rc)) rc = rCode + +end subroutine shr_ncread_field4dG +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_open -- Open netcdf file +! +! !DESCRIPTION: +! Open netcdf file +! +! \newline +! General Usage: +! call shr_ncread_open('myfile',fid) +! \newline +! !REVISION HISTORY: +! 2005-May-01 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_ncread_open(fileName,fid,rCode) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: fileName + integer(SHR_KIND_IN),intent(out) :: fid + integer(SHR_KIND_IN),intent(out) :: rCode + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n + logical :: exists + + !----- formats ----- + character(*),parameter :: subName = '(shr_ncread_open) ' + character(*),parameter :: F00 = "('(shr_ncread_open) ',4a)" + +!---------------------------------------------------------------------------- +! Notes: simply opens the file, does not acquire from anywhere (eg. mss:) +!---------------------------------------------------------------------------- + + !--- verify the file exists --- + inquire(file=trim(fileName),exist=exists) + if (.not.exists) then + if (s_loglev > 0) write(s_logunit,F00) "ERROR: file does not exist: ",trim(fileName) + call shr_ncread_handleErr(rCode,subName//"ERROR: file does not exist: "//trim(fileName)) + end if + + !--- open the data file --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'open netCDF data file: ',trim(fileName) + rCode = nf90_open(fileName,nf90_nowrite,fid) + call shr_ncread_handleErr(rCode, subName//"ERROR opening input data file") + +end subroutine shr_ncread_open +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_close -- Close netcdf file +! +! !DESCRIPTION: +! Close netcdf file +! +! \newline +! General Usage: +! call shr_ncread_close(fid) +! \newline +! !REVISION HISTORY: +! 2005-May-01 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_ncread_close(fid,rCode) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: fid + integer(SHR_KIND_IN),intent(out) :: rCode + +!EOP + + !----- formats ----- + character(*),parameter :: subName = "(shr_ncread_close)" + character(*),parameter :: F00 = "('(shr_ncread_close) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + !--- close the data file --- + if (debug > 1 .and. s_loglev > 0) write(s_logunit,F00) 'close netCDF input data file ' + rCode = nf90_close(fid) + call shr_ncread_handleErr(rCode, subName//" ERROR closing input data file") + +end subroutine shr_ncread_close +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_handleErr -- Print netCDF error message +! +! !DESCRIPTION: +! Print the error message corresponding to the netCDF error status +! +! \newline +! General Usage: +! call shr_ncread_handleErr(rCode,' check in xx call in subroutine yy ') +! \newline +! !REVISION HISTORY: +! 2005-Jan-31 - J. Schramm - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_handleErr(rCode, str) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent (in) :: rCode + character(*) ,intent (in) :: str + +!EOP + + !----- formats ----- + character(*),parameter :: F00 = "('(shr_ncread_handleErr) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (rCode /= nf90_noerr) then + write(s_logunit,F00) "netCDF error: ",trim(nf90_strerror(rCode)) + call shr_ncread_abort(str) + end if + +end subroutine shr_ncread_handleErr +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_setAbort -- Set local shr_ncread abort flag +! +! !DESCRIPTION: +! Set local shr_ncread abort flag, true = abort, false = print and continue +! \newline +! General Usage: +! call shr\_ncread\_setAbort(.false.) +! \newline +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_setAbort(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_ncread_setAbort') " + character(*),parameter :: F00 = "('(shr_ncread_setAbort) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + doabort = flag + +end subroutine shr_ncread_setAbort +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_setDebug -- Set local shr_ncread debug level +! +! !DESCRIPTION: +! Set local shr_ncread debug level, 0 = production +! \newline +! General Usage: +! call shr\_ncread\_setDebug(2) +! \newline +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_setDebug(iflag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(in) :: iflag + +!EOP + + !--- local --- + + !--- formats --- + character(*),parameter :: subName = "('shr_ncread_setDebug') " + character(*),parameter :: F00 = "('(shr_ncread_setDebug) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + debug = iflag + +end subroutine shr_ncread_setDebug +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_ncread_abort -- local abort call +! +! !DESCRIPTION: +! local abort call +! \newline +! General Usage: +! call shr\_ncread\_abort(' ERROR in subroutine xyz ') +! \newline +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_ncread_abort(string) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),optional,intent(IN) :: string + +!EOP + + !--- local --- + character(SHR_KIND_CL) :: lstring + character(*),parameter :: subName = "(shr_ncread_abort)" + character(*),parameter :: F00 = "('(shr_ncread_abort) ',a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lstring = '' + if (present(string)) lstring = string + + if (doabort) then + call shr_sys_abort(lstring) + else + write(s_logunit,F00) ' no abort:'//trim(lstring) + endif + +end subroutine shr_ncread_abort +!=============================================================================== +!=============================================================================== +end module shr_ncread_mod + diff --git a/share/csm_share/shr/shr_nl_mod.F90 b/share/csm_share/shr/shr_nl_mod.F90 new file mode 100644 index 000000000000..8380ff85524b --- /dev/null +++ b/share/csm_share/shr/shr_nl_mod.F90 @@ -0,0 +1,88 @@ +module shr_nl_mod + +! Utilities for namelist reading +! Adapted Fall 2012 from CAM's namelist_utils. + +implicit none +private + +save + +public :: & + shr_nl_find_group_name ! seek through a file to find a specified namelist + +contains + +! This routine probably discards more error code information than it needs to. + +subroutine shr_nl_find_group_name(unit, group, status) + + use shr_string_mod, only: shr_string_toLower + +!--------------------------------------------------------------------------------------- +! Purpose: +! Search a file that contains namelist input for the specified namelist group name. +! Leave the file positioned so that the current record is the first record of the +! input for the specified group. +! +! Method: +! Read the file line by line. Each line is searched for an '&' which may only +! be preceded by blanks, immediately followed by the group name which is case +! insensitive. If found then backspace the file so the current record is the +! one containing the group name and return success. Otherwise return -1. +! +! Author: B. Eaton, August 2007 +!--------------------------------------------------------------------------------------- + + integer, intent(in) :: unit ! fortran unit attached to file + character(len=*), intent(in) :: group ! namelist group name + integer, intent(out) :: status ! 0 for success, -1 if group name not found + + ! Local variables + + integer :: len_grp + integer :: ios ! io status + character(len=80) :: inrec ! first 80 characters of input record + character(len=80) :: inrec2 ! left adjusted input record + character(len=len(group)) :: lc_group + + !--------------------------------------------------------------------------- + + len_grp = len_trim(group) + lc_group = shr_string_toLower(group) + + ios = 0 + do while (ios <= 0) + + read(unit, '(a)', iostat=ios, end=100) inrec + + if (ios <= 0) then ! ios < 0 indicates an end of record condition + + ! look for group name in this record + + ! remove leading blanks + inrec2 = adjustl(inrec) + + ! check for leading '&' + if (inrec2(1:1) == '&') then + + ! check for case insensitive group name + if (trim(lc_group) == shr_string_toLower(inrec2(2:len_grp+1))) then + + ! found group name. backspace to leave file position at this record + backspace(unit) + status = 0 + return + + end if + end if + end if + + end do + + 100 continue ! end of file processing + status = -1 + +end subroutine shr_nl_find_group_name + +end module shr_nl_mod diff --git a/share/csm_share/shr/shr_orb_mod.F90 b/share/csm_share/shr/shr_orb_mod.F90 new file mode 100644 index 000000000000..1e3da9c993ab --- /dev/null +++ b/share/csm_share/shr/shr_orb_mod.F90 @@ -0,0 +1,792 @@ +!=============================================================================== +! SVN $Id: shr_orb_mod.F90 25434 2010-11-04 22:46:24Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/release_tags/cesm1_2_x_n02_share3_130715/shr/shr_orb_mod.F90 $ +!=============================================================================== + +MODULE shr_orb_mod + + use shr_kind_mod, only: SHR_KIND_R8, SHR_KIND_IN + use shr_sys_mod + use shr_const_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + IMPLICIT none + + !---------------------------------------------------------------------------- + ! PUBLIC: Interfaces and global data + !---------------------------------------------------------------------------- + public :: shr_orb_cosz + public :: shr_orb_params + public :: shr_orb_decl + public :: shr_orb_print + + real (SHR_KIND_R8),public,parameter :: SHR_ORB_UNDEF_REAL = 1.e36_SHR_KIND_R8 ! undefined real + integer(SHR_KIND_IN),public,parameter :: SHR_ORB_UNDEF_INT = 2000000000 ! undefined int + + !---------------------------------------------------------------------------- + ! PRIVATE: by default everything else is private to this module + !---------------------------------------------------------------------------- + private + + real (SHR_KIND_R8),parameter :: pi = SHR_CONST_PI + real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MIN = 0.0_SHR_KIND_R8 ! min value for eccen + real (SHR_KIND_R8),parameter :: SHR_ORB_ECCEN_MAX = 0.1_SHR_KIND_R8 ! max value for eccen + real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MIN = -90.0_SHR_KIND_R8 ! min value for obliq + real (SHR_KIND_R8),parameter :: SHR_ORB_OBLIQ_MAX = +90.0_SHR_KIND_R8 ! max value for obliq + real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MIN = 0.0_SHR_KIND_R8 ! min value for mvelp + real (SHR_KIND_R8),parameter :: SHR_ORB_MVELP_MAX = 360.0_SHR_KIND_R8 ! max value for mvelp + + +!=============================================================================== +CONTAINS +!=============================================================================== + +real(SHR_KIND_R8) pure FUNCTION shr_orb_cosz(jday,lat,lon,declin,dt_avg) + + !---------------------------------------------------------------------------- + ! + ! FUNCTION to return the cosine of the solar zenith angle. + ! Assumes 365.0 days/year. + ! + !--------------- Code History ----------------------------------------------- + ! + ! Original Author: Brian Kauffman + ! Date: Jan/98 + ! History: adapted from statement FUNCTION in share/orb_cosz.h + ! + !---------------------------------------------------------------------------- + + real (SHR_KIND_R8),intent(in) :: jday ! Julian cal day (1.xx to 365.xx) + real (SHR_KIND_R8),intent(in) :: lat ! Centered latitude (radians) + real (SHR_KIND_R8),intent(in) :: lon ! Centered longitude (radians) + real (SHR_KIND_R8),intent(in) :: declin ! Solar declination (radians) + real (SHR_KIND_R8),intent(in), optional :: dt_avg ! if present and set non-zero, then use in the + ! average cosz calculation + logical :: use_dt_avg + + !---------------------------------------------------------------------------- + + use_dt_avg = .false. + if (present(dt_avg)) then + if (dt_avg /= 0.0_shr_kind_r8) use_dt_avg = .true. + end if + + + ! If dt for the average cosz is specified, then call the shr_orb_avg_cosz + if (use_dt_avg) then + shr_orb_cosz = shr_orb_avg_cosz(jday, lat, lon, declin, dt_avg) + else + shr_orb_cosz = sin(lat)*sin(declin) - & + & cos(lat)*cos(declin)*cos(jday*2.0_SHR_KIND_R8*pi + lon) + end if + +END FUNCTION shr_orb_cosz + +!======================================================================= +! A New Algorithm for Calculation of Cosine Solar Zenith Angle +! Author: Linjiong Zhou +! E-mail: linjiongzhou@hotmail.com +! Date : 2015.02.22 +! Ref. : Zhou et al., GRL, 2015 +!======================================================================= + +real (SHR_KIND_R8) pure function shr_orb_avg_cosz(jday, lat, lon, declin, dt_avg) + + use shr_const_mod, only : pi => shr_const_pi + + implicit none + +!----------------------------------------------------------------------- +! In/Out Arguements + + real(SHR_KIND_R8), intent(in) :: jday ! Julian calendar day (1.xx to 365.xx) + real(SHR_KIND_R8), intent(in) :: lat ! latitude (radian) + real(SHR_KIND_R8), intent(in) :: lon ! longitude (radian) + real(SHR_KIND_R8), intent(in) :: declin ! solar declination (radian) + real(SHR_KIND_R8), intent(in) :: dt_avg ! dt for averaged cosz calculation + +!----------------------------------------------------------------------- +! Local Arguments + + real(SHR_KIND_R8),parameter :: piover2 = pi/2.0_SHR_KIND_R8 + real(SHR_KIND_R8),parameter :: twopi = pi*2.0_SHR_KIND_R8 + + real(SHR_KIND_R8) :: aa, bb + real(SHR_KIND_R8) :: del, phi + real(SHR_KIND_R8) :: cos_h, h + real(SHR_KIND_R8) :: t1, t2, dt + real(SHR_KIND_R8) :: tt1, tt2, tt3, tt4 + +!----------------------------------------------------------------------- +! Compute Half-day Length + + ! adjust latitude so that its tangent will be defined + if (lat == piover2) then + del = lat - 1.0e-05_SHR_KIND_R8 + else if (lat == -piover2) then + del = lat + 1.0e-05_SHR_KIND_R8 + else + del = lat + end if + + ! adjust declination so that its tangent will be defined + if (declin == piover2) then + phi = declin - 1.0e-05_SHR_KIND_R8 + else if (declin == -piover2) then + phi = declin + 1.0e-05_SHR_KIND_R8 + else + phi = declin + end if + + ! define the cosine of the half-day length + ! adjust for cases of all daylight or all night + cos_h = - tan(del) * tan(phi) + if (cos_h <= -1.0_SHR_KIND_R8) then + h = pi + else if (cos_h >= 1.0_SHR_KIND_R8) then + h = 0.0_SHR_KIND_R8 + else + h = acos(cos_h) + end if + +!----------------------------------------------------------------------- +! Define Local Time t and t + dt + + ! adjust t to be between -pi and pi + t1 = (jday - int(jday)) * twopi + lon - pi + + if (t1 >= pi) then + t1 = t1 - twopi + else if (t1 < -pi) then + t1 = t1 + twopi + end if + + dt = dt_avg / 86400.0_SHR_KIND_R8 * twopi + t2 = t1 + dt + +!----------------------------------------------------------------------- +! Compute Cosine Solar Zenith angle + + ! define terms needed in the cosine zenith angle equation + aa = sin(lat) * sin(declin) + bb = cos(lat) * cos(declin) + + ! define the hour angle + ! force it to be between -h and h + ! consider the situation when the night period is too short + if (t2 >= pi .and. t1 <= pi .and. pi - h <= dt) then + tt2 = h + tt1 = min(max(t1, -h) , h) + tt4 = min(max(t2, twopi - h), twopi + h) + tt3 = twopi - h + else if (t2 >= -pi .and. t1 <= -pi .and. pi - h <= dt) then + tt2 = - twopi + h + tt1 = min(max(t1, -twopi - h), -twopi + h) + tt4 = min(max(t2, -h) , h) + tt3 = -h + else + if (t2 > pi) then + tt2 = min(max(t2 - twopi, -h), h) + else if (t2 < - pi) then + tt2 = min(max(t2 + twopi, -h), h) + else + tt2 = min(max(t2 , -h), h) + end if + if (t1 > pi) then + tt1 = min(max(t1 - twopi, -h), h) + else if (t1 < - pi) then + tt1 = min(max(t1 + twopi, -h), h) + else + tt1 = min(max(t1 , -h), h) + end if + tt4 = 0.0_SHR_KIND_R8 + tt3 = 0.0_SHR_KIND_R8 + end if + + ! perform a time integration to obtain cosz if desired + ! output is valid over the period from t to t + dt + if (tt2 > tt1 .or. tt4 > tt3) then + shr_orb_avg_cosz = (aa * (tt2 - tt1) + bb * (sin(tt2) - sin(tt1))) / dt + & + (aa * (tt4 - tt3) + bb * (sin(tt4) - sin(tt3))) / dt + else + shr_orb_avg_cosz = 0.0_SHR_KIND_R8 + end if + +end function shr_orb_avg_cosz + +!=============================================================================== + +SUBROUTINE shr_orb_params( iyear_AD , eccen , obliq , mvelp , & + & obliqr , lambm0 , mvelpp, log_print ) + +!------------------------------------------------------------------------------- +! +! Calculate earths orbital parameters using Dave Threshers formula which +! came from Berger, Andre. 1978 "A Simple Algorithm to Compute Long-Term +! Variations of Daily Insolation". Contribution 18, Institute of Astronomy +! and Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium +! +!------------------------------Code history------------------------------------- +! +! Original Author: Erik Kluzek +! Date: Oct/97 +! +!------------------------------------------------------------------------------- + + !----------------------------- Arguments ------------------------------------ + integer(SHR_KIND_IN),intent(in) :: iyear_AD ! Year to calculate orbit for + real (SHR_KIND_R8),intent(inout) :: eccen ! orbital eccentricity + real (SHR_KIND_R8),intent(inout) :: obliq ! obliquity in degrees + real (SHR_KIND_R8),intent(inout) :: mvelp ! moving vernal equinox long + real (SHR_KIND_R8),intent(out) :: obliqr ! Earths obliquity in rad + real (SHR_KIND_R8),intent(out) :: lambm0 ! Mean long of perihelion at + ! vernal equinox (radians) + real (SHR_KIND_R8),intent(out) :: mvelpp ! moving vernal equinox long + ! of perihelion plus pi (rad) + logical ,intent(in) :: log_print ! Flags print of status/error + + !------------------------------ Parameters ---------------------------------- + integer(SHR_KIND_IN),parameter :: poblen =47 ! # of elements in series wrt obliquity + integer(SHR_KIND_IN),parameter :: pecclen=19 ! # of elements in series wrt eccentricity + integer(SHR_KIND_IN),parameter :: pmvelen=78 ! # of elements in series wrt vernal equinox + real (SHR_KIND_R8),parameter :: psecdeg = 1.0_SHR_KIND_R8/3600.0_SHR_KIND_R8 ! arc sec to deg conversion + + real (SHR_KIND_R8) :: degrad = pi/180._SHR_KIND_R8 ! degree to radian conversion factor + real (SHR_KIND_R8) :: yb4_1950AD ! number of years before 1950 AD + + character(len=*),parameter :: subname = '(shr_orb_params)' + + ! Cosine series data for computation of obliquity: amplitude (arc seconds), + ! rate (arc seconds/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: obamp(poblen) = & ! amplitudes for obliquity cos series + & (/ -2462.2214466_SHR_KIND_R8, -857.3232075_SHR_KIND_R8, -629.3231835_SHR_KIND_R8, & + & -414.2804924_SHR_KIND_R8, -311.7632587_SHR_KIND_R8, 308.9408604_SHR_KIND_R8, & + & -162.5533601_SHR_KIND_R8, -116.1077911_SHR_KIND_R8, 101.1189923_SHR_KIND_R8, & + & -67.6856209_SHR_KIND_R8, 24.9079067_SHR_KIND_R8, 22.5811241_SHR_KIND_R8, & + & -21.1648355_SHR_KIND_R8, -15.6549876_SHR_KIND_R8, 15.3936813_SHR_KIND_R8, & + & 14.6660938_SHR_KIND_R8, -11.7273029_SHR_KIND_R8, 10.2742696_SHR_KIND_R8, & + & 6.4914588_SHR_KIND_R8, 5.8539148_SHR_KIND_R8, -5.4872205_SHR_KIND_R8, & + & -5.4290191_SHR_KIND_R8, 5.1609570_SHR_KIND_R8, 5.0786314_SHR_KIND_R8, & + & -4.0735782_SHR_KIND_R8, 3.7227167_SHR_KIND_R8, 3.3971932_SHR_KIND_R8, & + & -2.8347004_SHR_KIND_R8, -2.6550721_SHR_KIND_R8, -2.5717867_SHR_KIND_R8, & + & -2.4712188_SHR_KIND_R8, 2.4625410_SHR_KIND_R8, 2.2464112_SHR_KIND_R8, & + & -2.0755511_SHR_KIND_R8, -1.9713669_SHR_KIND_R8, -1.8813061_SHR_KIND_R8, & + & -1.8468785_SHR_KIND_R8, 1.8186742_SHR_KIND_R8, 1.7601888_SHR_KIND_R8, & + & -1.5428851_SHR_KIND_R8, 1.4738838_SHR_KIND_R8, -1.4593669_SHR_KIND_R8, & + & 1.4192259_SHR_KIND_R8, -1.1818980_SHR_KIND_R8, 1.1756474_SHR_KIND_R8, & + & -1.1316126_SHR_KIND_R8, 1.0896928_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: obrate(poblen) = & ! rates for obliquity cosine series + & (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, & + & 31.983787_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 30.973257_SHR_KIND_R8, & + & 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, 30.599444_SHR_KIND_R8, & + & 42.681324_SHR_KIND_R8, 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, & + & 63.219948_SHR_KIND_R8, 64.230478_SHR_KIND_R8, 1.010530_SHR_KIND_R8, & + & 7.437771_SHR_KIND_R8, 55.782177_SHR_KIND_R8, 0.373813_SHR_KIND_R8, & + & 13.218362_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, & + & 76.438310_SHR_KIND_R8, 45.815258_SHR_KIND_R8, 8.448301_SHR_KIND_R8, & + & 56.792707_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 12.058272_SHR_KIND_R8, & + & 75.278220_SHR_KIND_R8, 65.241008_SHR_KIND_R8, 64.604291_SHR_KIND_R8, & + & 1.647247_SHR_KIND_R8, 7.811584_SHR_KIND_R8, 12.207832_SHR_KIND_R8, & + & 63.856665_SHR_KIND_R8, 56.155990_SHR_KIND_R8, 77.448840_SHR_KIND_R8, & + & 6.801054_SHR_KIND_R8, 62.209418_SHR_KIND_R8, 20.656133_SHR_KIND_R8, & + & 48.344406_SHR_KIND_R8, 55.145460_SHR_KIND_R8, 69.000539_SHR_KIND_R8, & + & 11.071350_SHR_KIND_R8, 74.291298_SHR_KIND_R8, 11.047742_SHR_KIND_R8, & + & 0.636717_SHR_KIND_R8, 12.844549_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: obphas(poblen) = & ! phases for obliquity cosine series + & (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, & + & 292.7252_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 263.7951_SHR_KIND_R8, & + & 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, 222.9725_SHR_KIND_R8, & + & 268.7809_SHR_KIND_R8, 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, & + & 143.8050_SHR_KIND_R8, 172.7351_SHR_KIND_R8, 28.9300_SHR_KIND_R8, & + & 123.5968_SHR_KIND_R8, 20.2082_SHR_KIND_R8, 40.8226_SHR_KIND_R8, & + & 123.4722_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, & + & 267.2772_SHR_KIND_R8, 55.0196_SHR_KIND_R8, 152.5268_SHR_KIND_R8, & + & 49.1382_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 56.5233_SHR_KIND_R8, & + & 200.3284_SHR_KIND_R8, 201.6651_SHR_KIND_R8, 213.5577_SHR_KIND_R8, & + & 17.0374_SHR_KIND_R8, 164.4194_SHR_KIND_R8, 94.5422_SHR_KIND_R8, & + & 131.9124_SHR_KIND_R8, 61.0309_SHR_KIND_R8, 296.2073_SHR_KIND_R8, & + & 135.4894_SHR_KIND_R8, 114.8750_SHR_KIND_R8, 247.0691_SHR_KIND_R8, & + & 256.6114_SHR_KIND_R8, 32.1008_SHR_KIND_R8, 143.6804_SHR_KIND_R8, & + & 16.8784_SHR_KIND_R8, 160.6835_SHR_KIND_R8, 27.5932_SHR_KIND_R8, & + & 348.1074_SHR_KIND_R8, 82.6496_SHR_KIND_R8/) + + ! Cosine/sine series data for computation of eccentricity and fixed vernal + ! equinox longitude of perihelion (fvelp): amplitude, + ! rate (arc seconds/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: ecamp (pecclen) = & ! ampl for eccen/fvelp cos/sin series + & (/ 0.01860798_SHR_KIND_R8, 0.01627522_SHR_KIND_R8, -0.01300660_SHR_KIND_R8, & + & 0.00988829_SHR_KIND_R8, -0.00336700_SHR_KIND_R8, 0.00333077_SHR_KIND_R8, & + & -0.00235400_SHR_KIND_R8, 0.00140015_SHR_KIND_R8, 0.00100700_SHR_KIND_R8, & + & 0.00085700_SHR_KIND_R8, 0.00064990_SHR_KIND_R8, 0.00059900_SHR_KIND_R8, & + & 0.00037800_SHR_KIND_R8, -0.00033700_SHR_KIND_R8, 0.00027600_SHR_KIND_R8, & + & 0.00018200_SHR_KIND_R8, -0.00017400_SHR_KIND_R8, -0.00012400_SHR_KIND_R8, & + & 0.00001250_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: ecrate(pecclen) = & ! rates for eccen/fvelp cos/sin series + & (/ 4.2072050_SHR_KIND_R8, 7.3460910_SHR_KIND_R8, 17.8572630_SHR_KIND_R8, & + & 17.2205460_SHR_KIND_R8, 16.8467330_SHR_KIND_R8, 5.1990790_SHR_KIND_R8, & + & 18.2310760_SHR_KIND_R8, 26.2167580_SHR_KIND_R8, 6.3591690_SHR_KIND_R8, & + & 16.2100160_SHR_KIND_R8, 3.0651810_SHR_KIND_R8, 16.5838290_SHR_KIND_R8, & + & 18.4939800_SHR_KIND_R8, 6.1909530_SHR_KIND_R8, 18.8677930_SHR_KIND_R8, & + & 17.4255670_SHR_KIND_R8, 6.1860010_SHR_KIND_R8, 18.4174410_SHR_KIND_R8, & + & 0.6678630_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: ecphas(pecclen) = & ! phases for eccen/fvelp cos/sin series + & (/ 28.620089_SHR_KIND_R8, 193.788772_SHR_KIND_R8, 308.307024_SHR_KIND_R8, & + & 320.199637_SHR_KIND_R8, 279.376984_SHR_KIND_R8, 87.195000_SHR_KIND_R8, & + & 349.129677_SHR_KIND_R8, 128.443387_SHR_KIND_R8, 154.143880_SHR_KIND_R8, & + & 291.269597_SHR_KIND_R8, 114.860583_SHR_KIND_R8, 332.092251_SHR_KIND_R8, & + & 296.414411_SHR_KIND_R8, 145.769910_SHR_KIND_R8, 337.237063_SHR_KIND_R8, & + & 152.092288_SHR_KIND_R8, 126.839891_SHR_KIND_R8, 210.667199_SHR_KIND_R8, & + & 72.108838_SHR_KIND_R8/) + + ! Sine series data for computation of moving vernal equinox longitude of + ! perihelion: amplitude (arc seconds), rate (arc sec/year), phase (degrees). + + real (SHR_KIND_R8), parameter :: mvamp (pmvelen) = & ! amplitudes for mvelp sine series + & (/ 7391.0225890_SHR_KIND_R8, 2555.1526947_SHR_KIND_R8, 2022.7629188_SHR_KIND_R8, & + & -1973.6517951_SHR_KIND_R8, 1240.2321818_SHR_KIND_R8, 953.8679112_SHR_KIND_R8, & + & -931.7537108_SHR_KIND_R8, 872.3795383_SHR_KIND_R8, 606.3544732_SHR_KIND_R8, & + & -496.0274038_SHR_KIND_R8, 456.9608039_SHR_KIND_R8, 346.9462320_SHR_KIND_R8, & + & -305.8412902_SHR_KIND_R8, 249.6173246_SHR_KIND_R8, -199.1027200_SHR_KIND_R8, & + & 191.0560889_SHR_KIND_R8, -175.2936572_SHR_KIND_R8, 165.9068833_SHR_KIND_R8, & + & 161.1285917_SHR_KIND_R8, 139.7878093_SHR_KIND_R8, -133.5228399_SHR_KIND_R8, & + & 117.0673811_SHR_KIND_R8, 104.6907281_SHR_KIND_R8, 95.3227476_SHR_KIND_R8, & + & 86.7824524_SHR_KIND_R8, 86.0857729_SHR_KIND_R8, 70.5893698_SHR_KIND_R8, & + & -69.9719343_SHR_KIND_R8, -62.5817473_SHR_KIND_R8, 61.5450059_SHR_KIND_R8, & + & -57.9364011_SHR_KIND_R8, 57.1899832_SHR_KIND_R8, -57.0236109_SHR_KIND_R8, & + & -54.2119253_SHR_KIND_R8, 53.2834147_SHR_KIND_R8, 52.1223575_SHR_KIND_R8, & + & -49.0059908_SHR_KIND_R8, -48.3118757_SHR_KIND_R8, -45.4191685_SHR_KIND_R8, & + & -42.2357920_SHR_KIND_R8, -34.7971099_SHR_KIND_R8, 34.4623613_SHR_KIND_R8, & + & -33.8356643_SHR_KIND_R8, 33.6689362_SHR_KIND_R8, -31.2521586_SHR_KIND_R8, & + & -30.8798701_SHR_KIND_R8, 28.4640769_SHR_KIND_R8, -27.1960802_SHR_KIND_R8, & + & 27.0860736_SHR_KIND_R8, -26.3437456_SHR_KIND_R8, 24.7253740_SHR_KIND_R8, & + & 24.6732126_SHR_KIND_R8, 24.4272733_SHR_KIND_R8, 24.0127327_SHR_KIND_R8, & + & 21.7150294_SHR_KIND_R8, -21.5375347_SHR_KIND_R8, 18.1148363_SHR_KIND_R8, & + & -16.9603104_SHR_KIND_R8, -16.1765215_SHR_KIND_R8, 15.5567653_SHR_KIND_R8, & + & 15.4846529_SHR_KIND_R8, 15.2150632_SHR_KIND_R8, 14.5047426_SHR_KIND_R8, & + & -14.3873316_SHR_KIND_R8, 13.1351419_SHR_KIND_R8, 12.8776311_SHR_KIND_R8, & + & 11.9867234_SHR_KIND_R8, 11.9385578_SHR_KIND_R8, 11.7030822_SHR_KIND_R8, & + & 11.6018181_SHR_KIND_R8, -11.2617293_SHR_KIND_R8, -10.4664199_SHR_KIND_R8, & + & 10.4333970_SHR_KIND_R8, -10.2377466_SHR_KIND_R8, 10.1934446_SHR_KIND_R8, & + & -10.1280191_SHR_KIND_R8, 10.0289441_SHR_KIND_R8, -10.0034259_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: mvrate(pmvelen) = & ! rates for mvelp sine series + & (/ 31.609974_SHR_KIND_R8, 32.620504_SHR_KIND_R8, 24.172203_SHR_KIND_R8, & + & 0.636717_SHR_KIND_R8, 31.983787_SHR_KIND_R8, 3.138886_SHR_KIND_R8, & + & 30.973257_SHR_KIND_R8, 44.828336_SHR_KIND_R8, 0.991874_SHR_KIND_R8, & + & 0.373813_SHR_KIND_R8, 43.668246_SHR_KIND_R8, 32.246691_SHR_KIND_R8, & + & 30.599444_SHR_KIND_R8, 2.147012_SHR_KIND_R8, 10.511172_SHR_KIND_R8, & + & 42.681324_SHR_KIND_R8, 13.650058_SHR_KIND_R8, 0.986922_SHR_KIND_R8, & + & 9.874455_SHR_KIND_R8, 13.013341_SHR_KIND_R8, 0.262904_SHR_KIND_R8, & + & 0.004952_SHR_KIND_R8, 1.142024_SHR_KIND_R8, 63.219948_SHR_KIND_R8, & + & 0.205021_SHR_KIND_R8, 2.151964_SHR_KIND_R8, 64.230478_SHR_KIND_R8, & + & 43.836462_SHR_KIND_R8, 47.439436_SHR_KIND_R8, 1.384343_SHR_KIND_R8, & + & 7.437771_SHR_KIND_R8, 18.829299_SHR_KIND_R8, 9.500642_SHR_KIND_R8, & + & 0.431696_SHR_KIND_R8, 1.160090_SHR_KIND_R8, 55.782177_SHR_KIND_R8, & + & 12.639528_SHR_KIND_R8, 1.155138_SHR_KIND_R8, 0.168216_SHR_KIND_R8, & + & 1.647247_SHR_KIND_R8, 10.884985_SHR_KIND_R8, 5.610937_SHR_KIND_R8, & + & 12.658184_SHR_KIND_R8, 1.010530_SHR_KIND_R8, 1.983748_SHR_KIND_R8, & + & 14.023871_SHR_KIND_R8, 0.560178_SHR_KIND_R8, 1.273434_SHR_KIND_R8, & + & 12.021467_SHR_KIND_R8, 62.583231_SHR_KIND_R8, 63.593761_SHR_KIND_R8, & + & 76.438310_SHR_KIND_R8, 4.280910_SHR_KIND_R8, 13.218362_SHR_KIND_R8, & + & 17.818769_SHR_KIND_R8, 8.359495_SHR_KIND_R8, 56.792707_SHR_KIND_R8, & + & 8.448301_SHR_KIND_R8, 1.978796_SHR_KIND_R8, 8.863925_SHR_KIND_R8, & + & 0.186365_SHR_KIND_R8, 8.996212_SHR_KIND_R8, 6.771027_SHR_KIND_R8, & + & 45.815258_SHR_KIND_R8, 12.002811_SHR_KIND_R8, 75.278220_SHR_KIND_R8, & + & 65.241008_SHR_KIND_R8, 18.870667_SHR_KIND_R8, 22.009553_SHR_KIND_R8, & + & 64.604291_SHR_KIND_R8, 11.498094_SHR_KIND_R8, 0.578834_SHR_KIND_R8, & + & 9.237738_SHR_KIND_R8, 49.747842_SHR_KIND_R8, 2.147012_SHR_KIND_R8, & + & 1.196895_SHR_KIND_R8, 2.133898_SHR_KIND_R8, 0.173168_SHR_KIND_R8/) + + real (SHR_KIND_R8), parameter :: mvphas(pmvelen) = & ! phases for mvelp sine series + & (/ 251.9025_SHR_KIND_R8, 280.8325_SHR_KIND_R8, 128.3057_SHR_KIND_R8, & + & 348.1074_SHR_KIND_R8, 292.7252_SHR_KIND_R8, 165.1686_SHR_KIND_R8, & + & 263.7951_SHR_KIND_R8, 15.3747_SHR_KIND_R8, 58.5749_SHR_KIND_R8, & + & 40.8226_SHR_KIND_R8, 308.4258_SHR_KIND_R8, 240.0099_SHR_KIND_R8, & + & 222.9725_SHR_KIND_R8, 106.5937_SHR_KIND_R8, 114.5182_SHR_KIND_R8, & + & 268.7809_SHR_KIND_R8, 279.6869_SHR_KIND_R8, 39.6448_SHR_KIND_R8, & + & 126.4108_SHR_KIND_R8, 291.5795_SHR_KIND_R8, 307.2848_SHR_KIND_R8, & + & 18.9300_SHR_KIND_R8, 273.7596_SHR_KIND_R8, 143.8050_SHR_KIND_R8, & + & 191.8927_SHR_KIND_R8, 125.5237_SHR_KIND_R8, 172.7351_SHR_KIND_R8, & + & 316.7998_SHR_KIND_R8, 319.6024_SHR_KIND_R8, 69.7526_SHR_KIND_R8, & + & 123.5968_SHR_KIND_R8, 217.6432_SHR_KIND_R8, 85.5882_SHR_KIND_R8, & + & 156.2147_SHR_KIND_R8, 66.9489_SHR_KIND_R8, 20.2082_SHR_KIND_R8, & + & 250.7568_SHR_KIND_R8, 48.0188_SHR_KIND_R8, 8.3739_SHR_KIND_R8, & + & 17.0374_SHR_KIND_R8, 155.3409_SHR_KIND_R8, 94.1709_SHR_KIND_R8, & + & 221.1120_SHR_KIND_R8, 28.9300_SHR_KIND_R8, 117.1498_SHR_KIND_R8, & + & 320.5095_SHR_KIND_R8, 262.3602_SHR_KIND_R8, 336.2148_SHR_KIND_R8, & + & 233.0046_SHR_KIND_R8, 155.6977_SHR_KIND_R8, 184.6277_SHR_KIND_R8, & + & 267.2772_SHR_KIND_R8, 78.9281_SHR_KIND_R8, 123.4722_SHR_KIND_R8, & + & 188.7132_SHR_KIND_R8, 180.1364_SHR_KIND_R8, 49.1382_SHR_KIND_R8, & + & 152.5268_SHR_KIND_R8, 98.2198_SHR_KIND_R8, 97.4808_SHR_KIND_R8, & + & 221.5376_SHR_KIND_R8, 168.2438_SHR_KIND_R8, 161.1199_SHR_KIND_R8, & + & 55.0196_SHR_KIND_R8, 262.6495_SHR_KIND_R8, 200.3284_SHR_KIND_R8, & + & 201.6651_SHR_KIND_R8, 294.6547_SHR_KIND_R8, 99.8233_SHR_KIND_R8, & + & 213.5577_SHR_KIND_R8, 154.1631_SHR_KIND_R8, 232.7153_SHR_KIND_R8, & + & 138.3034_SHR_KIND_R8, 204.6609_SHR_KIND_R8, 106.5938_SHR_KIND_R8, & + & 250.4676_SHR_KIND_R8, 332.3345_SHR_KIND_R8, 27.3039_SHR_KIND_R8/) + + !---------------------------Local variables---------------------------------- + integer(SHR_KIND_IN) :: i ! Index for series summations + real (SHR_KIND_R8) :: obsum ! Obliquity series summation + real (SHR_KIND_R8) :: cossum ! Cos series summation for eccentricity/fvelp + real (SHR_KIND_R8) :: sinsum ! Sin series summation for eccentricity/fvelp + real (SHR_KIND_R8) :: fvelp ! Fixed vernal equinox long of perihelion + real (SHR_KIND_R8) :: mvsum ! mvelp series summation + real (SHR_KIND_R8) :: beta ! Intermediate argument for lambm0 + real (SHR_KIND_R8) :: years ! Years to time of interest ( pos <=> future) + real (SHR_KIND_R8) :: eccen2 ! eccentricity squared + real (SHR_KIND_R8) :: eccen3 ! eccentricity cubed + + !-------------------------- Formats ----------------------------------------- + character(len=*),parameter :: F00 = "('(shr_orb_params) ',4a)" + character(len=*),parameter :: F01 = "('(shr_orb_params) ',a,i9)" + character(len=*),parameter :: F02 = "('(shr_orb_params) ',a,f6.3)" + character(len=*),parameter :: F03 = "('(shr_orb_params) ',a,es14.6)" + + !---------------------------------------------------------------------------- + ! radinp and algorithms below will need a degree to radian conversion factor + + if ( log_print .and. s_loglev > 0 ) then + write(s_logunit,F00) 'Calculate characteristics of the orbit:' + end if + + ! Check for flag to use input orbit parameters + + IF ( iyear_AD == SHR_ORB_UNDEF_INT ) THEN + + ! Check input obliq, eccen, and mvelp to ensure reasonable + + if( obliq == SHR_ORB_UNDEF_REAL )then + write(s_logunit,F00) trim(subname)//' Have to specify orbital parameters:' + write(s_logunit,F00) 'Either set: iyear_AD, OR [obliq, eccen, and mvelp]:' + write(s_logunit,F00) 'iyear_AD is the year to simulate orbit for (ie. 1950): ' + write(s_logunit,F00) 'obliq, eccen, mvelp specify the orbit directly:' + write(s_logunit,F00) 'The AMIP II settings (for a 1995 orbit) are: ' + write(s_logunit,F00) ' obliq = 23.4441' + write(s_logunit,F00) ' eccen = 0.016715' + write(s_logunit,F00) ' mvelp = 102.7' + call shr_sys_abort(subname//' ERROR: unreasonable obliq') + else if ( log_print ) then + write(s_logunit,F00) 'Use input orbital parameters: ' + end if + if( (obliq < SHR_ORB_OBLIQ_MIN).or.(obliq > SHR_ORB_OBLIQ_MAX) ) then + write(s_logunit,F03) 'Input obliquity unreasonable: ', obliq + call shr_sys_abort(subname//' ERROR: unreasonable obliq') + end if + if( (eccen < SHR_ORB_ECCEN_MIN).or.(eccen > SHR_ORB_ECCEN_MAX) ) then + write(s_logunit,F03) 'Input eccentricity unreasonable: ', eccen + call shr_sys_abort(subname//' ERROR: unreasonable eccen') + end if + if( (mvelp < SHR_ORB_MVELP_MIN).or.(mvelp > SHR_ORB_MVELP_MAX) ) then + write(s_logunit,F03) 'Input mvelp unreasonable: ' , mvelp + call shr_sys_abort(subname//' ERROR: unreasonable mvelp') + end if + eccen2 = eccen*eccen + eccen3 = eccen2*eccen + + ELSE ! Otherwise calculate based on years before present + + if ( log_print .and. s_loglev > 0) then + write(s_logunit,F01) 'Calculate orbit for year: ' , iyear_AD + end if + yb4_1950AD = 1950.0_SHR_KIND_R8 - real(iyear_AD,SHR_KIND_R8) + if ( abs(yb4_1950AD) .gt. 1000000.0_SHR_KIND_R8 )then + write(s_logunit,F00) 'orbit only valid for years+-1000000' + write(s_logunit,F00) 'Relative to 1950 AD' + write(s_logunit,F03) '# of years before 1950: ',yb4_1950AD + write(s_logunit,F01) 'Year to simulate was : ',iyear_AD + call shr_sys_abort(subname//' ERROR: unreasonable year') + end if + + ! The following calculates the earths obliquity, orbital eccentricity + ! (and various powers of it) and vernal equinox mean longitude of + ! perihelion for years in the past (future = negative of years past), + ! using constants (see parameter section) given in the program of: + ! + ! Berger, Andre. 1978 A Simple Algorithm to Compute Long-Term Variations + ! of Daily Insolation. Contribution 18, Institute of Astronomy and + ! Geophysics, Universite Catholique de Louvain, Louvain-la-Neuve, Belgium. + ! + ! and formulas given in the paper (where less precise constants are also + ! given): + ! + ! Berger, Andre. 1978. Long-Term Variations of Daily Insolation and + ! Quaternary Climatic Changes. J. of the Atmo. Sci. 35:2362-2367 + ! + ! The algorithm is valid only to 1,000,000 years past or hence. + ! For a solution valid to 5-10 million years past see the above author. + ! Algorithm below is better for years closer to present than is the + ! 5-10 million year solution. + ! + ! Years to time of interest must be negative of years before present + ! (1950) in formulas that follow. + + years = - yb4_1950AD + + ! In the summations below, cosine or sine arguments, which end up in + ! degrees, must be converted to radians via multiplication by degrad. + ! + ! Summation of cosine series for obliquity (epsilon in Berger 1978) in + ! degrees. Convert the amplitudes and rates, which are in arc secs, into + ! degrees via multiplication by psecdeg (arc seconds to degrees conversion + ! factor). For obliq, first term is Berger 1978 epsilon star; second + ! term is series summation in degrees. + + obsum = 0.0_SHR_KIND_R8 + do i = 1, poblen + obsum = obsum + obamp(i)*psecdeg*cos((obrate(i)*psecdeg*years + & + & obphas(i))*degrad) + end do + obliq = 23.320556_SHR_KIND_R8 + obsum + + ! Summation of cosine and sine series for computation of eccentricity + ! (eccen; e in Berger 1978) and fixed vernal equinox longitude of + ! perihelion (fvelp; pi in Berger 1978), which is used for computation + ! of moving vernal equinox longitude of perihelion. Convert the rates, + ! which are in arc seconds, into degrees via multiplication by psecdeg. + + cossum = 0.0_SHR_KIND_R8 + do i = 1, pecclen + cossum = cossum+ecamp(i)*cos((ecrate(i)*psecdeg*years+ecphas(i))*degrad) + end do + + sinsum = 0.0_SHR_KIND_R8 + do i = 1, pecclen + sinsum = sinsum+ecamp(i)*sin((ecrate(i)*psecdeg*years+ecphas(i))*degrad) + end do + + ! Use summations to calculate eccentricity + + eccen2 = cossum*cossum + sinsum*sinsum + eccen = sqrt(eccen2) + eccen3 = eccen2*eccen + + ! A series of cases for fvelp, which is in radians. + + if (abs(cossum) .le. 1.0E-8_SHR_KIND_R8) then + if (sinsum .eq. 0.0_SHR_KIND_R8) then + fvelp = 0.0_SHR_KIND_R8 + else if (sinsum .lt. 0.0_SHR_KIND_R8) then + fvelp = 1.5_SHR_KIND_R8*pi + else if (sinsum .gt. 0.0_SHR_KIND_R8) then + fvelp = .5_SHR_KIND_R8*pi + endif + else if (cossum .lt. 0.0_SHR_KIND_R8) then + fvelp = atan(sinsum/cossum) + pi + else if (cossum .gt. 0.0_SHR_KIND_R8) then + if (sinsum .lt. 0.0_SHR_KIND_R8) then + fvelp = atan(sinsum/cossum) + 2.0_SHR_KIND_R8*pi + else + fvelp = atan(sinsum/cossum) + endif + endif + + ! Summation of sin series for computation of moving vernal equinox long + ! of perihelion (mvelp; omega bar in Berger 1978) in degrees. For mvelp, + ! first term is fvelp in degrees; second term is Berger 1978 psi bar + ! times years and in degrees; third term is Berger 1978 zeta; fourth + ! term is series summation in degrees. Convert the amplitudes and rates, + ! which are in arc seconds, into degrees via multiplication by psecdeg. + ! Series summation plus second and third terms constitute Berger 1978 + ! psi, which is the general precession. + + mvsum = 0.0_SHR_KIND_R8 + do i = 1, pmvelen + mvsum = mvsum + mvamp(i)*psecdeg*sin((mvrate(i)*psecdeg*years + & + & mvphas(i))*degrad) + end do + mvelp = fvelp/degrad + 50.439273_SHR_KIND_R8*psecdeg*years + 3.392506_SHR_KIND_R8 + mvsum + + ! Cases to make sure mvelp is between 0 and 360. + + do while (mvelp .lt. 0.0_SHR_KIND_R8) + mvelp = mvelp + 360.0_SHR_KIND_R8 + end do + do while (mvelp .ge. 360.0_SHR_KIND_R8) + mvelp = mvelp - 360.0_SHR_KIND_R8 + end do + + END IF ! end of test on whether to calculate or use input orbital params + + ! Orbit needs the obliquity in radians + + obliqr = obliq*degrad + + ! 180 degrees must be added to mvelp since observations are made from the + ! earth and the sun is considered (wrongly for the algorithm) to go around + ! the earth. For a more graphic explanation see Appendix B in: + ! + ! A. Berger, M. Loutre and C. Tricot. 1993. Insolation and Earth Orbital + ! Periods. J. of Geophysical Research 98:10,341-10,362. + ! + ! Additionally, orbit will need this value in radians. So mvelp becomes + ! mvelpp (mvelp plus pi) + + mvelpp = (mvelp + 180._SHR_KIND_R8)*degrad + + ! Set up an argument used several times in lambm0 calculation ahead. + + beta = sqrt(1._SHR_KIND_R8 - eccen2) + + ! The mean longitude at the vernal equinox (lambda m nought in Berger + ! 1978; in radians) is calculated from the following formula given in + ! Berger 1978. At the vernal equinox the true longitude (lambda in Berger + ! 1978) is 0. + + lambm0 = 2._SHR_KIND_R8*((.5_SHR_KIND_R8*eccen + .125_SHR_KIND_R8*eccen3)*(1._SHR_KIND_R8 + beta)*sin(mvelpp) & + & - .250_SHR_KIND_R8*eccen2*(.5_SHR_KIND_R8 + beta)*sin(2._SHR_KIND_R8*mvelpp) & + & + .125_SHR_KIND_R8*eccen3*(1._SHR_KIND_R8/3._SHR_KIND_R8 + beta)*sin(3._SHR_KIND_R8*mvelpp)) + + if ( log_print ) then + write(s_logunit,F03) '------ Computed Orbital Parameters ------' + write(s_logunit,F03) 'Eccentricity = ',eccen + write(s_logunit,F03) 'Obliquity (deg) = ',obliq + write(s_logunit,F03) 'Obliquity (rad) = ',obliqr + write(s_logunit,F03) 'Long of perh(deg) = ',mvelp + write(s_logunit,F03) 'Long of perh(rad) = ',mvelpp + write(s_logunit,F03) 'Long at v.e.(rad) = ',lambm0 + write(s_logunit,F03) '-----------------------------------------' + end if + +END SUBROUTINE shr_orb_params + +!=============================================================================== + +SUBROUTINE shr_orb_decl(calday ,eccen ,mvelpp ,lambm0 ,obliqr ,delta ,eccf) + +!------------------------------------------------------------------------------- +! +! Compute earth/orbit parameters using formula suggested by +! Duane Thresher. +! +!---------------------------Code history---------------------------------------- +! +! Original version: Erik Kluzek +! Date: Oct/1997 +! +!------------------------------------------------------------------------------- + + !------------------------------Arguments-------------------------------- + real (SHR_KIND_R8),intent(in) :: calday ! Calendar day, including fraction + real (SHR_KIND_R8),intent(in) :: eccen ! Eccentricity + real (SHR_KIND_R8),intent(in) :: obliqr ! Earths obliquity in radians + real (SHR_KIND_R8),intent(in) :: lambm0 ! Mean long of perihelion at the + ! vernal equinox (radians) + real (SHR_KIND_R8),intent(in) :: mvelpp ! moving vernal equinox longitude + ! of perihelion plus pi (radians) + real (SHR_KIND_R8),intent(out) :: delta ! Solar declination angle in rad + real (SHR_KIND_R8),intent(out) :: eccf ! Earth-sun distance factor (ie. (1/r)**2) + + !---------------------------Local variables----------------------------- + real (SHR_KIND_R8),parameter :: dayspy = 365.0_SHR_KIND_R8 ! days per year + real (SHR_KIND_R8),parameter :: ve = 80.5_SHR_KIND_R8 ! Calday of vernal equinox + ! assumes Jan 1 = calday 1 + + real (SHR_KIND_R8) :: lambm ! Lambda m, mean long of perihelion (rad) + real (SHR_KIND_R8) :: lmm ! Intermediate argument involving lambm + real (SHR_KIND_R8) :: lamb ! Lambda, the earths long of perihelion + real (SHR_KIND_R8) :: invrho ! Inverse normalized sun/earth distance + real (SHR_KIND_R8) :: sinl ! Sine of lmm + + ! Compute eccentricity factor and solar declination using + ! day value where a round day (such as 213.0) refers to 0z at + ! Greenwich longitude. + ! + ! Use formulas from Berger, Andre 1978: Long-Term Variations of Daily + ! Insolation and Quaternary Climatic Changes. J. of the Atmo. Sci. + ! 35:2362-2367. + ! + ! To get the earths true longitude (position in orbit; lambda in Berger + ! 1978) which is necessary to find the eccentricity factor and declination, + ! must first calculate the mean longitude (lambda m in Berger 1978) at + ! the present day. This is done by adding to lambm0 (the mean longitude + ! at the vernal equinox, set as March 21 at noon, when lambda=0; in radians) + ! an increment (delta lambda m in Berger 1978) that is the number of + ! days past or before (a negative increment) the vernal equinox divided by + ! the days in a model year times the 2*pi radians in a complete orbit. + + lambm = lambm0 + (calday - ve)*2._SHR_KIND_R8*pi/dayspy + lmm = lambm - mvelpp + + ! The earths true longitude, in radians, is then found from + ! the formula in Berger 1978: + + sinl = sin(lmm) + lamb = lambm + eccen*(2._SHR_KIND_R8*sinl + eccen*(1.25_SHR_KIND_R8*sin(2._SHR_KIND_R8*lmm) & + & + eccen*((13.0_SHR_KIND_R8/12.0_SHR_KIND_R8)*sin(3._SHR_KIND_R8*lmm) - 0.25_SHR_KIND_R8*sinl))) + + ! Using the obliquity, eccentricity, moving vernal equinox longitude of + ! perihelion (plus), and earths true longitude, the declination (delta) + ! and the normalized earth/sun distance (rho in Berger 1978; actually inverse + ! rho will be used), and thus the eccentricity factor (eccf), can be + ! calculated from formulas given in Berger 1978. + + invrho = (1._SHR_KIND_R8 + eccen*cos(lamb - mvelpp)) / (1._SHR_KIND_R8 - eccen*eccen) + + ! Set solar declination and eccentricity factor + + delta = asin(sin(obliqr)*sin(lamb)) + eccf = invrho*invrho + + return + +END SUBROUTINE shr_orb_decl + +!=============================================================================== + +SUBROUTINE shr_orb_print( iyear_AD, eccen, obliq, mvelp ) + +!------------------------------------------------------------------------------- +! +! Print out the information on the Earths input orbital characteristics +! +!---------------------------Code history---------------------------------------- +! +! Original version: Erik Kluzek +! Date: Oct/1997 +! +!------------------------------------------------------------------------------- + + !---------------------------Arguments---------------------------------------- + integer(SHR_KIND_IN),intent(in) :: iyear_AD ! requested Year (AD) + real (SHR_KIND_R8),intent(in) :: eccen ! eccentricity (unitless) + ! (typically 0 to 0.1) + real (SHR_KIND_R8),intent(in) :: obliq ! obliquity (-90 to +90 degrees) + ! typically 22-26 + real (SHR_KIND_R8),intent(in) :: mvelp ! moving vernal equinox at perhel + ! (0 to 360 degrees) + !-------------------------- Formats ----------------------------------------- + character(len=*),parameter :: F00 = "('(shr_orb_print) ',4a)" + character(len=*),parameter :: F01 = "('(shr_orb_print) ',a,i9.4)" + character(len=*),parameter :: F02 = "('(shr_orb_print) ',a,f6.3)" + character(len=*),parameter :: F03 = "('(shr_orb_print) ',a,es14.6)" + !---------------------------------------------------------------------------- + + if (s_loglev > 0) then + if ( iyear_AD .ne. SHR_ORB_UNDEF_INT ) then + if ( iyear_AD > 0 ) then + write(s_logunit,F01) 'Orbital parameters calculated for year: AD ',iyear_AD + else + write(s_logunit,F01) 'Orbital parameters calculated for year: BC ',iyear_AD + end if + else if ( obliq /= SHR_ORB_UNDEF_REAL ) then + write(s_logunit,F03) 'Orbital parameters: ' + write(s_logunit,F03) 'Obliquity (degree): ', obliq + write(s_logunit,F03) 'Eccentricity (unitless): ', eccen + write(s_logunit,F03) 'Long. of moving Perhelion (deg): ', mvelp + else + write(s_logunit,F03) 'Orbit parameters not set!' + end if + endif + +END SUBROUTINE shr_orb_print +!=============================================================================== + +END MODULE shr_orb_mod diff --git a/share/csm_share/shr/shr_pcdf_mod.F90 b/share/csm_share/shr/shr_pcdf_mod.F90 new file mode 100644 index 000000000000..41d58f75bc36 --- /dev/null +++ b/share/csm_share/shr/shr_pcdf_mod.F90 @@ -0,0 +1,832 @@ +!=============================================================================== +! SVN $Id: shr_pcdf_mod.F90 18683 2009-09-30 22:20:22Z kauff $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/drv/seq_mct/trunk_tags/drvseq3_0_36/driver/shr_pcdf_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_pcdf_mod -- generic pio file reader and writer +! +! !DESCRIPTION: +! +! Reads & writes pio files +! +! !REMARKS: +! +! supports aVect, 1d real and integer, and scalar real and integer fields +! using a common decomp for all fields. this is a heavily overloaded interface +! that supports read and write of multiple fields/type to a file using a single call. +! +! !REVISION HISTORY: +! 2009-Oct-15 - T. Craig - initial implementation +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_pcdf_mod + + use shr_kind_mod, only: R8 => SHR_KIND_R8, IN => SHR_KIND_IN + use shr_kind_mod, only: CL => SHR_KIND_CL, CS => SHR_KIND_CS + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + use shr_const_mod, only: shr_const_spval + use shr_log_mod, only: shr_log_unit, shr_log_level + use mct_mod + use pio + + implicit none + + private + + !PUBLIC TYPES: + + ! no public types + +!!PUBLIC MEMBER FUNCTIONS + + public :: shr_pcdf_readwrite + +!!PUBLIC DATA MEMBERS: + + ! no public data + +!EOP + + character(len=*),parameter :: version = 'shr_pcdf_v0_0_01' + real(r8) ,parameter :: fillvalue = SHR_CONST_SPVAL + integer(in) ,parameter :: ifillvalue = -999999 + +!=============================================================================== +contains +!=============================================================================== +subroutine shr_pcdf_readwrite(type,iosystem,pio_iotype,filename,mpicom,gsmap,dof,clobber,cdf64, & + id1,id1n,rs1,rs1n,is1,is1n,rf1,rf1n,if1,if1n,av1,av1n, & + id2,id2n,rs2,rs2n,is2,is2n,rf2,rf2n,if2,if2n,av2,av2n, & + id3,id3n,rs3,rs3n,is3,is3n,rf3,rf3n,if3,if3n,av3,av3n, & + id4,id4n,rs4,rs4n,is4,is4n,rf4,rf4n,if4,if4n,av4,av4n ) + use pio, only : iosystem_desc_t + implicit none + + character(len=*) , intent(in) :: type ! 'read' or 'write' + type(iosystem_desc_t), intent(inout), target :: iosystem + integer(IN), intent(in) :: pio_iotype + character(len=*) , intent(in) :: filename ! filename + integer(IN) , intent(in) :: mpicom ! mpicom + + !--- one of these must be set --- + type(mct_gsmap) , optional, intent(in) :: gsmap ! decomp for all data + integer(IN) , optional, intent(in) :: dof(:) ! decomp for all data + + !--- optional settings --- + logical , optional, intent(in) :: clobber + logical , optional, intent(in) :: cdf64 + ! add root, stride, ntasks, netcdf/pnetcdf, etc + + !--- data to write --- + + !--- single scalar dimensions, assumed valid on the io root pe --- + integer(IN) , optional, intent(inout) :: id1 ! int field 1 + character(len=*) , optional, intent(in) :: id1n ! if1 name + integer(IN) , optional, intent(inout) :: id2 ! int field 2 + character(len=*) , optional, intent(in) :: id2n ! if2 name + integer(IN) , optional, intent(inout) :: id3 ! int field 3 + character(len=*) , optional, intent(in) :: id3n ! if3 name + integer(IN) , optional, intent(inout) :: id4 ! int field 4 + character(len=*) , optional, intent(in) :: id4n ! if4 name + + !--- single scalar variables, assumed valid on the io root pe --- + real(R8) , optional, intent(inout) :: rs1 ! real field 1 + character(len=*) , optional, intent(in) :: rs1n ! rf1 name + real(R8) , optional, intent(inout) :: rs2 ! real field 2 + character(len=*) , optional, intent(in) :: rs2n ! rf2 name + real(R8) , optional, intent(inout) :: rs3 ! real field 3 + character(len=*) , optional, intent(in) :: rs3n ! rf3 name + real(R8) , optional, intent(inout) :: rs4 ! real field 4 + character(len=*) , optional, intent(in) :: rs4n ! rf4 name + integer(IN) , optional, intent(inout) :: is1 ! int field 1 + character(len=*) , optional, intent(in) :: is1n ! if1 name + integer(IN) , optional, intent(inout) :: is2 ! int field 2 + character(len=*) , optional, intent(in) :: is2n ! if2 name + integer(IN) , optional, intent(inout) :: is3 ! int field 3 + character(len=*) , optional, intent(in) :: is3n ! if3 name + integer(IN) , optional, intent(inout) :: is4 ! int field 4 + character(len=*) , optional, intent(in) :: is4n ! if4 name + + !--- single field, decomposed f90 data in 1d arrays --- + real(R8) , optional, intent(inout) :: rf1(:) ! real field 1 + character(len=*) , optional, intent(in) :: rf1n ! rf1 name + real(R8) , optional, intent(inout) :: rf2(:) ! real field 2 + character(len=*) , optional, intent(in) :: rf2n ! rf2 name + real(R8) , optional, intent(inout) :: rf3(:) ! real field 3 + character(len=*) , optional, intent(in) :: rf3n ! rf3 name + real(R8) , optional, intent(inout) :: rf4(:) ! real field 4 + character(len=*) , optional, intent(in) :: rf4n ! rf4 name + integer(IN) , optional, intent(inout) :: if1(:) ! int field 1 + character(len=*) , optional, intent(in) :: if1n ! if1 name + integer(IN) , optional, intent(inout) :: if2(:) ! int field 2 + character(len=*) , optional, intent(in) :: if2n ! if2 name + integer(IN) , optional, intent(inout) :: if3(:) ! int field 3 + character(len=*) , optional, intent(in) :: if3n ! if3 name + integer(IN) , optional, intent(inout) :: if4(:) ! int field 4 + character(len=*) , optional, intent(in) :: if4n ! if4 name + + !--- attr vect, decomposed f90 data in av datatype --- + type(mct_aVect) , optional, intent(inout) :: av1 ! avect 1 + character(len=*) , optional, intent(in) :: av1n ! av1 name + type(mct_aVect) , optional, intent(inout) :: av2 ! avect 2 + character(len=*) , optional, intent(in) :: av2n ! av2 name + type(mct_aVect) , optional, intent(inout) :: av3 ! avect 3 + character(len=*) , optional, intent(in) :: av3n ! av3 name + type(mct_aVect) , optional, intent(inout) :: av4 ! avect 4 + character(len=*) , optional, intent(in) :: av4n ! av4 name + + !--- local --- + integer(IN) :: iam,ntasks + integer(IN) :: ier,rcode + integer(IN) :: loop,minloop,maxloop + integer(IN) :: n,nf + logical :: readtype + integer(IN) :: lsize,gsize + logical :: lclobber + logical :: lcdf64 + logical :: exists + integer :: nmode + character(CL) :: fname + character(CL) :: vname + type(mct_string) :: mstring ! mct char type + integer(IN) :: dimid1(1) + + + type(file_desc_t) :: fid + type(var_desc_t) :: varid + type(io_desc_t) :: iodescd + type(io_desc_t) :: iodesci + integer(IN), pointer :: ldof(:) + + character(len=*),parameter :: subname = '(shr_pcdf_readwrite) ' + + !------------- + + if (trim(type) == 'read') then + readtype = .true. + elseif (trim(type) == 'write') then + readtype = .false. + else + call shr_sys_abort(subname//' ERROR: read write type invalid') + endif + + lclobber = .false. + if (present(clobber)) lclobber=clobber + + lcdf64 = .false. + if (present(cdf64)) lcdf64=cdf64 + + call mpi_comm_size(mpicom,ntasks,ier) + call mpi_comm_rank(mpicom,iam,ier) + + if (iam == 0) then + write(shr_log_unit,*) subname,' filename = ',trim(filename) + write(shr_log_unit,*) subname,' type = ',trim(type) + write(shr_log_unit,*) subname,' clobber = ',lclobber + write(shr_log_unit,*) subname,' cdf64 = ',lcdf64 + call shr_sys_flush(shr_log_unit) + endif + + if (present(gsmap) .and. present(dof)) then + call shr_sys_abort(trim(subname)//' ERROR: either gsmap OR dof must be an argument') + endif + if (present(gsmap)) then + lsize = mct_gsmap_lsize(gsmap,mpicom) + gsize = mct_gsmap_gsize(gsmap) + call mct_gsmap_OrderedPoints(gsmap, iam, ldof) + call pio_initdecomp(iosystem, pio_double, (/gsize/), ldof, iodescd) + call pio_initdecomp(iosystem, pio_int , (/gsize/), ldof, iodesci) + deallocate(ldof) + elseif (present(dof)) then + lsize = size(dof) + call shr_mpi_sum(lsize,gsize,mpicom,string=trim(subname),all=.true.) + call pio_initdecomp(iosystem, pio_double, (/gsize/), ldof, iodescd) + call pio_initdecomp(iosystem, pio_int , (/gsize/), ldof, iodesci) + else + call shr_sys_abort(trim(subname)//' ERROR: either gsmap OR dof must be an argument') + endif + + if (iam == 0) then + if (len_trim(filename) == 0) then + call shr_sys_abort(trim(subname)//' ERROR: filename is empty') + endif + inquire(file=trim(filename),exist=exists) + endif + call shr_mpi_bcast(exists,mpicom,trim(subname)//' exists') + + if (readtype) then + if (.not.exists) then + call shr_sys_abort(trim(subname)//' ERROR: '//trim(filename)//' doesnt exist') + endif + nmode = pio_nowrite + rcode = pio_openfile(iosystem, fid, pio_iotype, trim(filename), nmode) + else + if (.not.lclobber .and. exists) then + call shr_sys_abort(trim(subname)//' ERROR: '//trim(filename)//' exists, no clobber set') + endif + if (lclobber .or. .not.exists) then + nmode = pio_clobber + if (lcdf64) nmode = ior(nmode,PIO_64BIT_OFFSET) + rcode = pio_createfile(iosystem, fid, pio_iotype, trim(filename), nmode) + else + nmode = pio_write + if (lcdf64) nmode = ior(nmode,PIO_64BIT_OFFSET) + rcode = pio_openfile(iosystem, fid, pio_iotype, trim(filename), nmode) + endif + rcode = pio_put_att(fid,pio_global,"file_version",version) + endif + call pio_seterrorhandling(fid,PIO_INTERNAL_ERROR) + + if (readtype) then + minloop = 11 + maxloop = 11 + else + minloop = 21 + maxloop = 22 + endif + + ! loop = 11 is read + ! loop = 21 is define + ! loop = 22 is write + do loop = minloop,maxloop + + if (loop == 21) rcode = pio_def_dim(fid,'gsize',gsize,dimid1(1)) + + if (present(id1)) then + fname = 'id1' + if (present(id1n)) fname = trim(id1n) + if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id1) + if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id1) + endif + + if (present(id2)) then + fname = 'id2' + if (present(id2n)) fname = trim(id2n) + if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id2) + if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id2) + endif + + if (present(id3)) then + fname = 'id3' + if (present(id3n)) fname = trim(id3n) + if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id3) + if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id3) + endif + + if (present(id4)) then + fname = 'id4' + if (present(id4n)) fname = trim(id4n) + if (loop == 11) call shr_pcdf_readdim(fid,trim(fname),id4) + if (loop == 21) call shr_pcdf_writedim(fid,trim(fname),id4) + endif + + if (present(rs1)) then + fname = 'rs1' + if (present(rs1n)) fname = trim(rs1n) + if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs1) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) + if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs1) + endif + + if (present(rs2)) then + fname = 'rs2' + if (present(rs2n)) fname = trim(rs2n) + if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs2) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) + if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs2) + endif + + if (present(rs3)) then + fname = 'rs3' + if (present(rs3n)) fname = trim(rs3n) + if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs3) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) + if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs3) + endif + + if (present(rs4)) then + fname = 'rs4' + if (present(rs4n)) fname = trim(rs4n) + if (loop == 11) call shr_pcdf_readr0d(fid,trim(fname),rs4) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_DOUBLE) + if (loop == 22) call shr_pcdf_writer0d(fid,trim(fname),rs4) + endif + + if (present(is1)) then + fname = 'is1' + if (present(is1n)) fname = trim(is1n) + if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is1) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) + if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is1) + endif + + if (present(is2)) then + fname = 'is2' + if (present(is2n)) fname = trim(is2n) + if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is2) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) + if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is2) + endif + + if (present(is3)) then + fname = 'is3' + if (present(is3n)) fname = trim(is3n) + if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is3) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) + if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is3) + endif + + if (present(is4)) then + fname = 'is4' + if (present(is4n)) fname = trim(is4n) + if (loop == 11) call shr_pcdf_readi0d(fid,trim(fname),is4) + if (loop == 21) call shr_pcdf_defvar0d(fid,trim(fname),PIO_INT) + if (loop == 22) call shr_pcdf_writei0d(fid,trim(fname),is4) + endif + + if (present(rf1)) then + fname = 'rf1' + if (present(rf1n)) fname = trim(rf1n) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf1) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf1) + endif + + if (present(rf2)) then + fname = 'rf2' + if (present(rf2n)) fname = trim(rf2n) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf2) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf2) + endif + + if (present(rf3)) then + fname = 'rf3' + if (present(rf3n)) fname = trim(rf3n) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf3) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf3) + endif + + if (present(rf4)) then + fname = 'rf4' + if (present(rf4n)) fname = trim(rf4n) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(fname),iodescd,rf4) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(fname),iodescd,rf4) + endif + + if (present(if1)) then + fname = 'if1' + if (present(if1n)) fname = trim(if1n) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if1) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if1) + endif + + if (present(if2)) then + fname = 'if2' + if (present(if2n)) fname = trim(if2n) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if2) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if2) + endif + + if (present(if3)) then + fname = 'if3' + if (present(if3n)) fname = trim(if3n) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if3) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if3) + endif + + if (present(if4)) then + fname = 'if4' + if (present(if4n)) fname = trim(if4n) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(fname),iodesci,if4) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(fname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(fname),iodesci,if4) + endif + + if (present(av1)) then + fname = 'av1_' + if (present(av1n)) then + if (trim(av1n) == '') then + fname = trim(av1n) + else + fname = trim(av1n)//'_' + endif + endif + nf = mct_aVect_nRattr(av1) + do n = 1,nf + call mct_aVect_getRList(mstring,n,av1) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av1%rAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av1%rAttr(n,:)) + enddo + nf = mct_aVect_nIattr(av1) + do n = 1,nf + call mct_aVect_getIList(mstring,n,av1) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av1%iAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av1%iAttr(n,:)) + enddo + endif + + if (present(av2)) then + fname = 'av2_' + if (present(av2n)) then + if (trim(av2n) == '') then + fname = trim(av2n) + else + fname = trim(av2n)//'_' + endif + endif + nf = mct_aVect_nRattr(av2) + do n = 1,nf + call mct_aVect_getRList(mstring,n,av2) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av2%rAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av2%rAttr(n,:)) + enddo + nf = mct_aVect_nIattr(av2) + do n = 1,nf + call mct_aVect_getIList(mstring,n,av2) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av2%iAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av2%iAttr(n,:)) + enddo + endif + + if (present(av3)) then + fname = 'av3_' + if (present(av3n)) then + if (trim(av3n) == '') then + fname = trim(av3n) + else + fname = trim(av3n)//'_' + endif + endif + nf = mct_aVect_nRattr(av3) + do n = 1,nf + call mct_aVect_getRList(mstring,n,av3) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av3%rAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av3%rAttr(n,:)) + enddo + nf = mct_aVect_nIattr(av3) + do n = 1,nf + call mct_aVect_getIList(mstring,n,av3) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av3%iAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av3%iAttr(n,:)) + enddo + endif + + if (present(av4)) then + fname = 'av4_' + if (present(av4n)) then + if (trim(av4n) == '') then + fname = trim(av4n) + else + fname = trim(av4n)//'_' + endif + endif + nf = mct_aVect_nRattr(av4) + do n = 1,nf + call mct_aVect_getRList(mstring,n,av4) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readr1d(fid,trim(vname),iodescd,av4%rAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_DOUBLE,dimid1) + if (loop == 22) call shr_pcdf_writer1d(fid,trim(vname),iodescd,av4%rAttr(n,:)) + enddo + nf = mct_aVect_nIattr(av4) + do n = 1,nf + call mct_aVect_getIList(mstring,n,av4) + vname = trim(fname)//trim(mct_string_toChar(mstring)) + call mct_string_clean(mstring) + if (loop == 11) call shr_pcdf_readi1d(fid,trim(vname),iodesci,av4%iAttr(n,:)) + if (loop == 21) call shr_pcdf_defvar1d(fid,trim(vname),PIO_INT,dimid1) + if (loop == 22) call shr_pcdf_writei1d(fid,trim(vname),iodesci,av4%iAttr(n,:)) + enddo + endif + + if (loop == 21) rcode = pio_enddef(fid) + enddo + + call pio_freedecomp(fid,iodesci) + call pio_freedecomp(fid,iodescd) + call pio_closefile(fid) + +end subroutine shr_pcdf_readwrite + +!=============================================================================== +!=============================================================================== +subroutine shr_pcdf_defvar0d(fid,fname,vtype) + + implicit none + + type(file_desc_t),intent(in) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(in) :: vtype + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_defvar0d) ' + + !------------- + + rcode = pio_def_var(fid,trim(fname),vtype,varid) + +end subroutine shr_pcdf_defvar0d + +!=============================================================================== +subroutine shr_pcdf_defvar1d(fid,fname,vtype,dimid) + + implicit none + + type(file_desc_t),intent(in) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(in) :: vtype + integer(IN) ,intent(in) :: dimid(:) + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_defvar1d) ' + + !------------- + + rcode = pio_def_var(fid,trim(fname),vtype,dimid,varid) + +end subroutine shr_pcdf_defvar1d + +!=============================================================================== +subroutine shr_pcdf_readr1d(fid,fname,iodesc,r1d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + type(io_desc_t) ,intent(inout) :: iodesc + real(R8) ,intent(inout) :: r1d(:) + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: dimid(4),ndims + integer(IN) :: vsize,fsize + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_readr1d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + +!--tcraig, here vsize is global, fsize is local, what check if any? +! rcode = pio_inq_varndims(fid, varid, ndims) +! rcode = pio_inq_vardimid(fid, varid, dimid(1:ndims)) +! rcode = pio_inq_dimlen(fid, dimid(1), vsize) +! fsize = size(r1d) +! if (vsize /= fsize) then +! write(shr_log_unit,*) subname,' ERROR: vsize,fsize = ',vsize,fsize +! call shr_sys_abort(trim(subname)//' ERROR: vsize,fsize') +! endif + + call pio_read_darray(fid,varid,iodesc,r1d,rcode) + +end subroutine shr_pcdf_readr1d + +!=============================================================================== +subroutine shr_pcdf_writer1d(fid,fname,iodesc,r1d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + type(io_desc_t) ,intent(inout) :: iodesc + real(R8) ,intent(inout) :: r1d(:) + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: dimid(4) + integer(IN) :: vsize,fsize + real(R8) :: lfillvalue + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_writer1d) ' + + !------------- + + lfillvalue = fillvalue + + rcode = pio_inq_varid(fid,trim(fname),varid) + call pio_write_darray(fid, varid, iodesc, r1d, rcode, fillval=lfillvalue) + +end subroutine shr_pcdf_writer1d +!=============================================================================== +!=============================================================================== +subroutine shr_pcdf_readi1d(fid,fname,iodesc,i1d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + type(io_desc_t) ,intent(inout) :: iodesc + integer(IN) ,intent(inout) :: i1d(:) + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: dimid(4),ndims + integer(IN) :: vsize,fsize + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_readi1d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + +!--tcraig, here vsize is global, fsize is local, what check if any? +! rcode = pio_inq_varndims(fid, varid, ndims) +! rcode = pio_inq_vardimid(fid, varid, dimid(1:ndims)) +! rcode = pio_inq_dimlen(fid, dimid(1), vsize) +! fsize = size(i1d) +! if (vsize /= fsize) then +! write(shr_log_unit,*) subname,' ERROR: vsize,fsize = ',vsize,fsize +! call shr_sys_abort(trim(subname)//' ERROR: vsize,fsize') +! endif + + call pio_read_darray(fid,varid,iodesc,i1d,rcode) + +end subroutine shr_pcdf_readi1d + +!=============================================================================== +subroutine shr_pcdf_writei1d(fid,fname,iodesc,i1d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + type(io_desc_t) ,intent(inout) :: iodesc + integer(IN) ,intent(inout) :: i1d(:) + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: dimid(4) + integer(IN) :: vsize,fsize + integer(IN) :: lfillvalue + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_writei1d) ' + + !------------- + + lfillvalue = ifillvalue + + rcode = pio_inq_varid(fid,trim(fname),varid) + call pio_write_darray(fid, varid, iodesc, i1d, rcode, fillval=lfillvalue) + +end subroutine shr_pcdf_writei1d +!=============================================================================== +!=============================================================================== +subroutine shr_pcdf_readr0d(fid,fname,r0d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + real(R8) ,intent(inout) :: r0d + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_readr0d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + rcode = pio_get_var(fid,varid,r0d) + +end subroutine shr_pcdf_readr0d + +!=============================================================================== +subroutine shr_pcdf_writer0d(fid,fname,r0d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + real(R8) ,intent(inout) :: r0d + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_writer0d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + rcode = pio_put_var(fid, varid, r0d) + +end subroutine shr_pcdf_writer0d +!=============================================================================== +!=============================================================================== +subroutine shr_pcdf_readi0d(fid,fname,i0d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(inout) :: i0d + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_readi0d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + rcode = pio_get_var(fid,varid,i0d) + +end subroutine shr_pcdf_readi0d + +!=============================================================================== +subroutine shr_pcdf_writei0d(fid,fname,i0d) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(inout) :: i0d + + !--- local --- + type(var_desc_t) :: varid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_writei0d) ' + + !------------- + + rcode = pio_inq_varid(fid,trim(fname),varid) + rcode = pio_put_var(fid, varid, i0d) + +end subroutine shr_pcdf_writei0d +!=============================================================================== +!=============================================================================== +subroutine shr_pcdf_readdim(fid,fname,dim) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(inout) :: dim + + !--- local --- + integer(IN) :: dimid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_readdim) ' + + !------------- + + rcode = pio_inq_dimid(fid,trim(fname),dimid) + rcode = pio_inq_dimlen(fid,dimid,dim) + +end subroutine shr_pcdf_readdim + +!=============================================================================== +subroutine shr_pcdf_writedim(fid,fname,dim) + + implicit none + + type(file_desc_t),intent(inout) :: fid + character(len=*) ,intent(in) :: fname + integer(IN) ,intent(inout) :: dim + + !--- local --- + integer(IN) :: dimid + integer(IN) :: rcode + character(len=*),parameter :: subname = '(shr_pcdf_writedim) ' + + !------------- + + rcode = pio_def_dim(fid,trim(fname),dim,dimid) + +end subroutine shr_pcdf_writedim +!=============================================================================== +!=============================================================================== +!=============================================================================== + +end module shr_pcdf_mod diff --git a/share/csm_share/shr/shr_pio_mod.F90 b/share/csm_share/shr/shr_pio_mod.F90 new file mode 100644 index 000000000000..c416d516a9e8 --- /dev/null +++ b/share/csm_share/shr/shr_pio_mod.F90 @@ -0,0 +1,802 @@ +module shr_pio_mod + use pio + use shr_kind_mod, only : shr_kind_CS, shr_kind_cl, shr_kind_in + use shr_file_mod, only : shr_file_getunit, shr_file_freeunit + use shr_log_mod, only : shr_log_unit + use shr_mpi_mod, only : shr_mpi_bcast, shr_mpi_chkerr + use shr_sys_mod, only : shr_sys_abort +#ifndef NO_MPIMOD + use mpi, only : mpi_comm_null, mpi_comm_world +#endif + implicit none +#ifdef NO_MPIMOD +#include +#endif + private + public :: shr_pio_init1 + public :: shr_pio_init2 + public :: shr_pio_getiosys + public :: shr_pio_getiotype + public :: shr_pio_getioroot + public :: shr_pio_finalize + + interface shr_pio_getiotype + module procedure shr_pio_getiotype_fromid, shr_pio_getiotype_fromname + end interface + interface shr_pio_getiosys + module procedure shr_pio_getiosys_fromid, shr_pio_getiosys_fromname + end interface + interface shr_pio_getioroot + module procedure shr_pio_getioroot_fromid, shr_pio_getioroot_fromname + end interface + interface shr_pio_getindex + module procedure shr_pio_getindex_fromid, shr_pio_getindex_fromname + end interface + + + + type pio_comp_t + integer :: compid + integer :: pio_root + integer :: pio_stride + integer :: pio_numiotasks + integer :: pio_iotype + end type pio_comp_t + + character(len=16), allocatable :: io_compname(:) + type(pio_comp_t), allocatable :: pio_comp_settings(:) + type (iosystem_desc_t), allocatable, target :: iosystems(:) + integer :: io_comm + logical :: pio_async_interface + integer, allocatable :: io_compid(:) + integer :: pio_debug_level=0, pio_blocksize=0 + integer(kind=pio_offset_kind) :: pio_buffer_size_limit=-1 + type(pio_rearr_opt_t) :: pio_rearr_opts + integer :: total_comps=0 + +#define DEBUGI 1 + +#ifdef DEBUGI + integer :: drank +#endif + + +contains +!> +!! @public +!! @brief should be the first routine called after mpi_init. It reads the pio default settings from file drv_in, namelist pio_default_inparm +!! and, if pio_async_interface is true, splits the IO tasks away from the Compute tasks. It then returns the new compute comm in +!! Global_Comm and sets module variable io_comm. +!! +!< + subroutine shr_pio_init1(ncomps, nlfilename, Global_Comm) + integer, intent(in) :: ncomps + character(len=*) :: nlfilename + integer, intent(inout) :: Global_Comm + + + integer :: i, pio_root, pio_stride, pio_numiotasks, pio_iotype + integer :: mpigrp_world, mpigrp, ierr, mpicom + character(*),parameter :: subName = '(shr_pio_init1) ' + integer :: pelist(3,1) + + call shr_pio_read_default_namelist(nlfilename, Global_Comm, pio_stride, pio_root, pio_numiotasks, & + pio_iotype, pio_async_interface) + + + call MPI_comm_rank(Global_Comm, drank, ierr) + + io_comm = MPI_COMM_NULL + allocate(pio_comp_settings(ncomps)) + do i=1,ncomps + pio_comp_settings(i)%pio_root = pio_root + pio_comp_settings(i)%pio_stride = pio_stride + pio_comp_settings(i)%pio_numiotasks = pio_numiotasks + pio_comp_settings(i)%pio_iotype = pio_iotype + end do + if(pio_async_interface) then +#ifdef NO_MPI2 + call shr_sys_abort(subname//':: async IO requires an MPI2 compliant MPI library') +#else + + pelist(1,1) = pio_root + pelist(2,1) = pio_root + (pio_numiotasks-1)*pio_stride + pelist(3,1) = pio_stride + + call mpi_comm_group(GLOBAL_COMM, mpigrp_world, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_group mpigrp_world') + call mpi_group_range_incl(mpigrp_world, 1, pelist, mpigrp,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_group_range_incl mpigrp') + call mpi_comm_create(GLOBAL_COMM, mpigrp, io_comm, ierr) + + call mpi_group_range_excl(mpigrp_world, 1, pelist, mpigrp,ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_group_range_incl mpigrp') + call mpi_comm_create(GLOBAL_COMM, mpigrp, mpicom, ierr) + Global_COMM=mpicom + + print *,__FILE__,__LINE__,subname, ' complete' +#endif + end if + total_comps = ncomps + end subroutine shr_pio_init1 +!> +!! @public +!! @brief if pio_async_interface is true, tasks in io_comm do not return from this subroutine. +!! +!! if pio_async_interface is false each component namelist pio_inparm is read from compname_modelio.nml +!! Then a subset of each components compute tasks are Identified as IO tasks using the root, stride and count +!! variables to select the tasks. +!! +!< + + + subroutine shr_pio_init2(comp_id, comp_name, comp_iamin, comp_comm, comp_comm_iam) + use shr_string_mod, only : shr_string_toLower + integer, intent(in) :: comp_id(:) + logical, intent(in) :: comp_iamin(:) + character(len=*), intent(in) :: comp_name(:) + integer, intent(in) :: comp_comm(:), comp_comm_iam(:) + integer :: i + integer :: ncomps + character(len=shr_kind_cl) :: nlfilename, cname + type(iosystem_desc_t) :: iosys + character(*), parameter :: subName = '(shr_pio_init2) ' + + if(pio_debug_level>0) then + if(comp_comm_iam(1)==0) then + write(shr_log_unit,*) 'Setting pio_debuglevel : ',pio_debug_level + end if + call pio_setdebuglevel(pio_debug_level) + endif + ! 0 is a valid value of pio_buffer_size_limit + if(pio_buffer_size_limit>=0) then + if(comp_comm_iam(1)==0) then + write(shr_log_unit,*) 'Setting pio_buffer_size_limit : ',pio_buffer_size_limit + end if + call pio_set_buffer_size_limit(pio_buffer_size_limit) + endif + if(pio_blocksize>0) then + if(comp_comm_iam(1)==0) then + write(shr_log_unit,*) 'Setting pio_blocksize : ',pio_blocksize + end if + call pio_set_blocksize(pio_blocksize) + endif + + + + + allocate(io_compid(total_comps), io_compname(total_comps)) + + io_compid = comp_id + io_compname = comp_name + allocate(iosystems(total_comps)) + + if(pio_async_interface) then + call pio_init(total_comps,mpi_comm_world, comp_comm, io_comm, iosystems, rearr_opts=pio_rearr_opts) + i=1 + if(comp_comm_iam(i)==0) then + write(shr_log_unit,*) io_compname(i),' : pio_numiotasks = ',pio_comp_settings(i)%pio_numiotasks + write(shr_log_unit,*) io_compname(i),' : pio_stride = ',pio_comp_settings(i)%pio_stride + write(shr_log_unit,*) io_compname(i),' : pio_root = ',pio_comp_settings(i)%pio_root + write(shr_log_unit,*) io_compname(i),' : pio_iotype = ',pio_comp_settings(i)%pio_iotype + end if + + else + do i=1,total_comps + if(comp_iamin(i)) then + cname = comp_name(i) + if(len_trim(cname) <= 3) then + nlfilename=trim(shr_string_toLower(cname))//'_modelio.nml' + else + nlfilename=trim(shr_string_toLower(cname(1:3)))//'_modelio.nml_'//cname(4:8) + endif + + call shr_pio_read_component_namelist(nlfilename , comp_comm(i), pio_comp_settings(i)%pio_stride, & + pio_comp_settings(i)%pio_root, pio_comp_settings(i)%pio_numiotasks, & + pio_comp_settings(i)%pio_iotype) + call pio_init(comp_comm_iam(i), comp_comm(i), pio_comp_settings(i)%pio_numiotasks, 0, & + pio_comp_settings(i)%pio_stride, & + pio_rearr_subset, iosystems(i), & + base=pio_comp_settings(i)%pio_root, rearr_opts=pio_rearr_opts) + + if(comp_comm_iam(i)==0) then + write(shr_log_unit,*) io_compname(i),' : pio_numiotasks = ',pio_comp_settings(i)%pio_numiotasks + write(shr_log_unit,*) io_compname(i),' : pio_stride = ',pio_comp_settings(i)%pio_stride + write(shr_log_unit,*) io_compname(i),' : pio_root = ',pio_comp_settings(i)%pio_root + write(shr_log_unit,*) io_compname(i),' : pio_iotype = ',pio_comp_settings(i)%pio_iotype + end if + + + + end if + end do + end if + + + + + end subroutine shr_pio_init2 + + + +!=============================================================================== + subroutine shr_pio_finalize( ) + integer :: ierr + integer :: i + logical :: active + do i=1,total_comps +! print *,__FILE__,__LINE__,drank,i,iosystems(i)%iosysid + call pio_finalize(iosystems(i), ierr) + end do + + end subroutine shr_pio_finalize + +!=============================================================================== + function shr_pio_getiotype_fromid(compid) result(io_type) + integer, intent(in) :: compid + integer :: io_type + + io_type = pio_comp_settings(shr_pio_getindex(compid))%pio_iotype + + end function shr_pio_getiotype_fromid + + + function shr_pio_getiotype_fromname(component) result(io_type) + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + character(len=*), intent(in) :: component + integer :: io_type + + io_type = pio_comp_settings(shr_pio_getindex(component))%pio_iotype + + end function shr_pio_getiotype_fromname + +!=============================================================================== + function shr_pio_getioroot_fromid(compid) result(io_root) + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + integer, intent(in) :: compid + integer :: io_root + + io_root = pio_comp_settings(shr_pio_getindex(compid))%pio_root + + end function shr_pio_getioroot_fromid + + function shr_pio_getioroot_fromname(component) result(io_root) + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + character(len=*), intent(in) :: component + integer :: io_root + + io_root = pio_comp_settings(shr_pio_getindex(component))%pio_root + + + end function shr_pio_getioroot_fromname + + +!=============================================================================== + + !! Given a component name, return the index of that component. + !! This is the index into io_compid, io_compname, comp_pio_iotype, etc. + !! If the given component is not found, return -1 + + integer function shr_pio_getindex_fromid(compid) result(index) + implicit none + integer, intent(in) :: compid + integer :: i + + index = -1 + do i=1,total_comps + if(io_compid(i)==compid) then + index = i + exit + end if + end do + + if(index<0) then + call shr_sys_abort('shr_pio_getindex :: compid out of allowed range') + end if + end function shr_pio_getindex_fromid + + + integer function shr_pio_getindex_fromname(component) result(index) + use shr_string_mod, only : shr_string_toupper + + implicit none + + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + character(len=*), intent(in) :: component + + character(len=len(component)) :: component_ucase + integer :: i + + ! convert component name to upper case in order to match case in io_compname + component_ucase = shr_string_toUpper(component) + + index = -1 ! flag for not found + do i=1,size(io_compname) + if (trim(component_ucase) == trim(io_compname(i))) then + index = i + exit + end if + end do + if(index<0) then + call shr_sys_abort(' shr_pio_getindex:: compid out of allowed range') + end if + end function shr_pio_getindex_fromname + + function shr_pio_getiosys_fromid(compid) result(iosystem) + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + integer, intent(in) :: compid + type(iosystem_desc_t), pointer :: iosystem + + + iosystem => iosystems(shr_pio_getindex(compid)) + + end function shr_pio_getiosys_fromid + + function shr_pio_getiosys_fromname(component) result(iosystem) + ! 'component' must be equal to some element of io_compname(:) + ! (but it is case-insensitive) + character(len=*), intent(in) :: component + type(iosystem_desc_t), pointer :: iosystem + + iosystem => iosystems(shr_pio_getindex(component)) + + end function shr_pio_getiosys_fromname + +!=============================================================================== + + + + subroutine shr_pio_read_default_namelist(nlfilename, Comm, pio_stride, pio_root, pio_numiotasks, & + pio_iotype, pio_async_interface) + + character(len=*), intent(in) :: nlfilename + integer, intent(in) :: Comm + logical, intent(out) :: pio_async_interface + integer, intent(out) :: pio_stride, pio_root, pio_numiotasks, pio_iotype + + character(len=shr_kind_cs) :: pio_typename + character(len=shr_kind_cs) :: pio_rearr_comm_type, pio_rearr_comm_fcd + integer :: pio_rearr_comm_max_pend_req_comp2io + logical :: pio_rearr_comm_enable_hs_comp2io + logical :: pio_rearr_comm_enable_isend_comp2io + integer :: pio_rearr_comm_max_pend_req_io2comp + logical :: pio_rearr_comm_enable_hs_io2comp + logical :: pio_rearr_comm_enable_isend_io2comp + character(*),parameter :: subName = '(shr_pio_read_default_namelist) ' + + integer :: iam, ierr, npes, unitn + logical :: iamroot + + namelist /pio_default_inparm/ pio_stride, pio_root, pio_numiotasks, & + pio_typename, pio_async_interface, pio_debug_level, pio_blocksize,& + pio_buffer_size_limit, pio_rearr_comm_type, pio_rearr_comm_fcd, & + pio_rearr_comm_max_pend_req_comp2io, pio_rearr_comm_enable_hs_comp2io, & + pio_rearr_comm_enable_isend_comp2io, & + pio_rearr_comm_max_pend_req_io2comp, pio_rearr_comm_enable_hs_io2comp, & + pio_rearr_comm_enable_isend_io2comp + + + + call mpi_comm_rank(Comm, iam , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') + call mpi_comm_size(Comm, npes, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') + + if(iam==0) then + iamroot=.true. + else + iamroot=.false. + end if + + !-------------------------------------------------------------------------- + ! read io nml parameters + !-------------------------------------------------------------------------- + pio_stride = -99 ! set based on pio_numiotasks value when initialized < 0 + pio_numiotasks = -99 ! set based on pio_stride value when initialized < 0 + pio_root = -99 + pio_typename = 'nothing' + pio_blocksize= -99 ! io blocking size set internally in pio when < 0 + pio_buffer_size_limit = -99 ! io task memory buffer maximum set internally in pio when < 0 + pio_debug_level = 0 ! no debug info by default + pio_async_interface = .false. ! pio tasks are a subset of component tasks + + if(iamroot) then + unitn=shr_file_getunit() + open( unitn, file=trim(nlfilename), status='old' , iostat=ierr) + if(ierr/=0) then + write(shr_log_unit,*) 'File ',trim(nlfilename),' not found, setting default values.' + else + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=pio_default_inparm,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' end of file or end of record condition '//trim(nlfilename) ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + + call shr_pio_getiotypefromname(pio_typename, pio_iotype, pio_iotype_netcdf) + end if + end if + + + + call shr_pio_namelist_set(npes, Comm, pio_stride, pio_root, pio_numiotasks, pio_iotype, iamroot) + call shr_mpi_bcast(pio_debug_level, Comm) + call shr_mpi_bcast(pio_blocksize, Comm) + call shr_mpi_bcast(pio_buffer_size_limit, Comm) + call shr_mpi_bcast(pio_async_interface, Comm) + call shr_pio_rearr_opts_set(Comm, pio_rearr_comm_type, pio_rearr_comm_fcd, & + pio_rearr_comm_max_pend_req_comp2io, pio_rearr_comm_enable_hs_comp2io, & + pio_rearr_comm_enable_isend_comp2io, & + pio_rearr_comm_max_pend_req_io2comp, pio_rearr_comm_enable_hs_io2comp, & + pio_rearr_comm_enable_isend_io2comp, & + pio_numiotasks) + + end subroutine shr_pio_read_default_namelist + + subroutine shr_pio_read_component_namelist(nlfilename, Comm, pio_stride, pio_root, pio_numiotasks, pio_iotype) + character(len=*), intent(in) :: nlfilename + integer, intent(in) :: Comm + + integer, intent(inout) :: pio_stride, pio_root, pio_numiotasks, pio_iotype + character(len=SHR_KIND_CS) :: pio_typename + integer :: unitn + + integer :: iam, ierr, npes + logical :: iamroot + character(*),parameter :: subName = '(shr_pio_read_component_namelist) ' + integer :: pio_default_stride, pio_default_root, pio_default_numiotasks, pio_default_iotype + + namelist /pio_inparm/ pio_stride, pio_root, pio_numiotasks, & + pio_typename + + + + call mpi_comm_rank(Comm, iam , ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') + call mpi_comm_size(Comm, npes, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_size comm_world') + + if(iam==0) then + iamroot=.true. + else + iamroot=.false. + end if + + pio_default_stride = pio_stride + pio_default_root = pio_root + pio_default_numiotasks = pio_numiotasks + pio_default_iotype = pio_iotype + + + !-------------------------------------------------------------------------- + ! read io nml parameters + !-------------------------------------------------------------------------- + pio_stride = -99 ! set based on pio_numiotasks value when initialized < 0 + pio_numiotasks = -99 ! set based on pio_stride value when initialized < 0 + pio_root = -99 + pio_typename = 'nothing' + + if(iamroot) then + unitn=shr_file_getunit() + open( unitn, file=trim(nlfilename), status='old' , iostat=ierr) + if( ierr /= 0) then + write(shr_log_unit,*) 'No ',trim(nlfilename),' found, using defaults for pio settings' + else + ierr = 1 + do while( ierr /= 0 ) + read(unitn,nml=pio_inparm,iostat=ierr) + if (ierr < 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' end of file or end of record condition' ) + end if + end do + close(unitn) + call shr_file_freeUnit( unitn ) + + call shr_pio_getiotypefromname(pio_typename, pio_iotype, pio_default_iotype) + + if(pio_stride== -99) pio_stride = pio_default_stride + if(pio_root == -99) pio_root = pio_default_root + if(pio_numiotasks == -99) then +#if defined(BGP) || defined(BGL) + if(pio_default_numiotasks < 0 ) then + pio_numiotasks = pio_default_numiotasks + else + pio_numiotasks = min(pio_default_numiotasks,npes/pio_stride) + end if +#else + pio_numiotasks = min(pio_default_numiotasks,npes/pio_stride) +#endif + endif + endif + end if + + call shr_pio_namelist_set(npes, Comm, pio_stride, pio_root, pio_numiotasks, pio_iotype, iamroot) + + + end subroutine shr_pio_read_component_namelist + + subroutine shr_pio_getiotypefromname(typename, iotype, defaulttype) + use shr_string_mod, only : shr_string_toupper + character(len=*), intent(inout) :: typename + integer, intent(out) :: iotype + integer, intent(in) :: defaulttype + + typename = shr_string_toupper(typename) + if ( typename .eq. 'NETCDF' ) then + iotype = pio_iotype_netcdf + else if ( typename .eq. 'PNETCDF') then + iotype = pio_iotype_pnetcdf + else if ( typename .eq. 'NETCDF4P') then + iotype = pio_iotype_netcdf4p + else if ( typename .eq. 'NETCDF4C') then + iotype = pio_iotype_netcdf4c +! Not yet supported +! else if ( typename .eq. 'VDC') then +! iotype = pio_iotype_vdc + else if ( typename .eq. 'NOTHING') then + iotype = defaulttype + else if ( typename .eq. 'DEFAULT') then + iotype = defaulttype + else + write(shr_log_unit,*) 'shr_pio_mod: WARNING Bad io_type argument - using iotype_netcdf' + iotype=pio_iotype_netcdf + end if + + end subroutine shr_pio_getiotypefromname + +!=============================================================================== + subroutine shr_pio_namelist_set(npes,mycomm, pio_stride, pio_root, pio_numiotasks, pio_iotype, iamroot) + integer, intent(in) :: npes, mycomm + integer, intent(inout) :: pio_stride, pio_root, pio_numiotasks + integer, intent(inout) :: pio_iotype + logical, intent(in) :: iamroot + character(*),parameter :: subName = '(shr_pio_namelist_set) ' + + call shr_mpi_bcast(pio_iotype , mycomm) + call shr_mpi_bcast(pio_stride , mycomm) + call shr_mpi_bcast(pio_root , mycomm) + call shr_mpi_bcast(pio_numiotasks, mycomm) + + if (pio_root<0) then + pio_root = 1 + endif + pio_root = min(pio_root,npes-1) + + +#if defined(BGP) || defined(BGL) +! On Bluegene machines a negative numiotasks refers to the number of iotasks per ionode, this code +! allows for that special case. + if(pio_numiotasks<0) then + pio_stride=0 + else +#endif + + + + + + !-------------------------------------------------------------------------- + ! check/set/correct io pio parameters + !-------------------------------------------------------------------------- + if (pio_stride>0.and.pio_numiotasks<0) then + pio_numiotasks = npes/pio_stride + else if(pio_numiotasks>0 .and. pio_stride<0) then + pio_stride = npes/pio_numiotasks + else if(pio_numiotasks<0 .and. pio_stride<0) then + pio_stride = 4 + pio_numiotasks = npes/pio_stride + pio_numiotasks = max(1, pio_numiotasks) + end if + + + if (pio_root + (pio_stride)*(pio_numiotasks-1) >= npes .or. & + pio_stride<=0 .or. pio_numiotasks<=0 .or. pio_root < 0 .or. & + pio_root > npes-1) then + if(npes<100) then + pio_stride = max(1,npes/4) + else if(npes<1000) then + pio_stride = max(1,npes/8) + else + pio_stride = max(1,npes/16) + end if + if(pio_stride>1) then + pio_numiotasks = npes/pio_stride + pio_root = min(1,npes-1) + else + pio_numiotasks = npes + pio_root = 0 + end if + if( iamroot) then + write(shr_log_unit,*) 'pio_stride, iotasks or root out of bounds - resetting to defaults: ',& + pio_stride,pio_numiotasks, pio_root + end if + end if +#if defined(BGP) || defined(BGL) + end if +#endif + + end subroutine shr_pio_namelist_set + + ! This subroutine sets the global PIO rearranger options + ! The input args that represent the rearranger options are valid only + ! on the root proc of comm + ! The rearranger options are passed to PIO_Init() in shr_pio_init2() + subroutine shr_pio_rearr_opts_set(comm, pio_rearr_comm_type, pio_rearr_comm_fcd, & + pio_rearr_comm_max_pend_req_comp2io, pio_rearr_comm_enable_hs_comp2io, & + pio_rearr_comm_enable_isend_comp2io, & + pio_rearr_comm_max_pend_req_io2comp, pio_rearr_comm_enable_hs_io2comp, & + pio_rearr_comm_enable_isend_io2comp, & + pio_numiotasks) + integer(SHR_KIND_IN), intent(in) :: comm + character(len=shr_kind_cs), intent(in) :: pio_rearr_comm_type, pio_rearr_comm_fcd + integer, intent(in) :: pio_rearr_comm_max_pend_req_comp2io + logical, intent(in) :: pio_rearr_comm_enable_hs_comp2io + logical, intent(in) :: pio_rearr_comm_enable_isend_comp2io + integer, intent(in) :: pio_rearr_comm_max_pend_req_io2comp + logical, intent(in) :: pio_rearr_comm_enable_hs_io2comp + logical, intent(in) :: pio_rearr_comm_enable_isend_io2comp + integer, intent(in) :: pio_numiotasks + + character(*), parameter :: subname = '(shr_pio_rearr_opts_set) ' + integer, parameter :: NUM_REARR_COMM_OPTS = 8 + integer, parameter :: PIO_REARR_COMM_DEF_MAX_PEND_REQ = 64 + integer(SHR_KIND_IN), dimension(NUM_REARR_COMM_OPTS) :: buf + integer :: rank, ierr + + call mpi_comm_rank(comm, rank, ierr) + call shr_mpi_chkerr(ierr,subname//' mpi_comm_rank comm_world') + + buf = 0 + ! buf(1) = comm_type + ! buf(2) = comm_fcd + ! buf(3) = max_pend_req_comp2io + ! buf(4) = enable_hs_comp2io + ! buf(5) = enable_isend_comp2io + ! buf(6) = max_pend_req_io2comp + ! buf(7) = enable_hs_io2comp + ! buf(8) = enable_isend_io2comp + if(rank == 0) then + ! buf(1) = comm_type + select case(pio_rearr_comm_type) + case ("p2p") + case ("default") + buf(1) = pio_rearr_comm_p2p + case ("coll") + buf(1) = pio_rearr_comm_coll + case default + write(shr_log_unit,*) "Invalid PIO rearranger comm type, ", pio_rearr_comm_type + write(shr_log_unit,*) "Resetting PIO rearrange comm type to p2p" + buf(1) = pio_rearr_comm_p2p + end select + + ! buf(2) = comm_fcd + select case(pio_rearr_comm_fcd) + case ("2denable") + case ("default") + buf(2) = pio_rearr_comm_fc_2d_enable + case ("io2comp") + buf(2) = pio_rearr_comm_fc_1d_io2comp + case ("comp2io") + buf(2) = pio_rearr_comm_fc_1d_comp2io + case ("disable") + buf(2) = pio_rearr_comm_fc_2d_disable + case default + write(shr_log_unit,*) "Invalid PIO rearranger comm flow control direction, ", pio_rearr_comm_fcd + write(shr_log_unit,*) "Resetting PIO rearrange comm flow control direction to 2denable" + buf(2) = pio_rearr_comm_fc_2d_enable + end select + + ! buf(3) = max_pend_req_comp2io + if((pio_rearr_comm_max_pend_req_comp2io <= 0) .and. & + (pio_rearr_comm_max_pend_req_comp2io /= PIO_REARR_COMM_UNLIMITED_PEND_REQ)) then + ! Small multiple of pio_numiotasks has proven to perform + ! well empirically, and we do not want to allow maximum for + ! very large process count runs. Can improve this by + ! communicating between iotasks first, and then non-iotasks + ! to iotasks (TO DO). + write(shr_log_unit, *) "Invalid PIO rearranger comm max pend req (comp2io), ", pio_rearr_comm_max_pend_req_comp2io + write(shr_log_unit, *) "Resetting PIO rearranger comm max pend req (comp2io) to ", max(PIO_REARR_COMM_DEF_MAX_PEND_REQ, 2 * pio_numiotasks) + buf(3) = max(PIO_REARR_COMM_DEF_MAX_PEND_REQ, 2 * pio_numiotasks) + else + buf(3) = pio_rearr_comm_max_pend_req_comp2io + end if + + ! buf(4) = enable_hs_comp2io + if(pio_rearr_comm_enable_hs_comp2io) then + buf(4) = 1 + else + buf(4) = 0 + end if + + ! buf(5) = enable_isend_comp2io + if(pio_rearr_comm_enable_isend_comp2io) then + buf(5) = 1 + else + buf(5) = 0 + end if + + ! buf(6) = max_pend_req_io2comp + if((pio_rearr_comm_max_pend_req_io2comp <= 0) .and. & + (pio_rearr_comm_max_pend_req_io2comp /= PIO_REARR_COMM_UNLIMITED_PEND_REQ)) then + write(shr_log_unit, *) "Invalid PIO rearranger comm max pend req (io2comp), ", pio_rearr_comm_max_pend_req_io2comp + write(shr_log_unit, *) "Resetting PIO rearranger comm max pend req (io2comp) to ", PIO_REARR_COMM_DEF_MAX_PEND_REQ + buf(6) = PIO_REARR_COMM_DEF_MAX_PEND_REQ + else + buf(6) = pio_rearr_comm_max_pend_req_io2comp + end if + + ! buf(7) = enable_hs_io2comp + if(pio_rearr_comm_enable_hs_io2comp) then + buf(7) = 1 + else + buf(7) = 0 + end if + + ! buf(8) = enable_isend_io2comp + if(pio_rearr_comm_enable_isend_io2comp) then + buf(8) = 1 + else + buf(8) = 0 + end if + + ! Log the rearranger options + write(shr_log_unit, *) "PIO rearranger options:" + write(shr_log_unit, *) " comm type =", pio_rearr_comm_type + write(shr_log_unit, *) " comm fcd =", pio_rearr_comm_fcd + write(shr_log_unit, *) " max pend req (comp2io) =", pio_rearr_comm_max_pend_req_comp2io + write(shr_log_unit, *) " enable_hs (comp2io) =", pio_rearr_comm_enable_hs_comp2io + write(shr_log_unit, *) " enable_isend (comp2io) =", pio_rearr_comm_enable_isend_comp2io + write(shr_log_unit, *) " max pend req (io2comp) =", pio_rearr_comm_max_pend_req_io2comp + write(shr_log_unit, *) " enable_hs (io2comp) =", pio_rearr_comm_enable_hs_io2comp + write(shr_log_unit, *) " enable_isend (io2comp) =", pio_rearr_comm_enable_isend_io2comp + end if + + call shr_mpi_bcast(buf, comm) + + ! buf(1) = comm_type + ! buf(2) = comm_fcd + ! buf(3) = max_pend_req_comp2io + ! buf(4) = enable_hs_comp2io + ! buf(5) = enable_isend_comp2io + ! buf(6) = max_pend_req_io2comp + ! buf(7) = enable_hs_io2comp + ! buf(8) = enable_isend_io2comp + pio_rearr_opts%comm_type = buf(1) + pio_rearr_opts%fcd = buf(2) + pio_rearr_opts%comm_fc_opts_comp2io%max_pend_req = buf(3) + if(buf(4) == 0) then + pio_rearr_opts%comm_fc_opts_comp2io%enable_hs = .false. + else + pio_rearr_opts%comm_fc_opts_comp2io%enable_hs = .true. + end if + if(buf(5) == 0) then + pio_rearr_opts%comm_fc_opts_comp2io%enable_isend = .false. + else + pio_rearr_opts%comm_fc_opts_comp2io%enable_isend = .true. + end if + pio_rearr_opts%comm_fc_opts_io2comp%max_pend_req = buf(6) + if(buf(7) == 0) then + pio_rearr_opts%comm_fc_opts_io2comp%enable_hs = .false. + else + pio_rearr_opts%comm_fc_opts_io2comp%enable_hs = .true. + end if + if(buf(8) == 0) then + pio_rearr_opts%comm_fc_opts_io2comp%enable_isend = .false. + else + pio_rearr_opts%comm_fc_opts_io2comp%enable_isend = .true. + end if + end subroutine + +!=============================================================================== + +end module shr_pio_mod diff --git a/share/csm_share/shr/shr_precip_mod.F90 b/share/csm_share/shr/shr_precip_mod.F90 new file mode 100644 index 000000000000..2c15f99f40c0 --- /dev/null +++ b/share/csm_share/shr/shr_precip_mod.F90 @@ -0,0 +1,47 @@ +module shr_precip_mod + + ! This module contains methods for manipulating precipitation quantities + + use shr_kind_mod, only : r8 => SHR_KIND_R8 + + implicit none + private + save + + ! determine a rain-snow partitioning using a ramp method based on temperature + public :: shr_precip_partition_rain_snow_ramp + +contains + + !----------------------------------------------------------------------- + subroutine shr_precip_partition_rain_snow_ramp(temperature, frac_rain) + ! + ! !DESCRIPTION: + ! Determine a rain-snow partitioning using a ramp method based on temperature. + ! + ! Returns fractional mass of precipitation falling as rain. The rest (1 - frac_rain) + ! falls as snow. + ! + ! This is meant to be used for precipitation at the surface, e.g., to force CLM. + ! + ! !USES: + use shr_const_mod, only : SHR_CONST_TKFRZ + ! + ! !ARGUMENTS: + real(r8), intent(in) :: temperature ! temperature (K) + real(r8), intent(out) :: frac_rain ! fraction of precipitation falling as rain + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'shr_precip_partition_rain_snow_ramp' + !----------------------------------------------------------------------- + + ! ramp near freezing + frac_rain = (temperature - SHR_CONST_TKFRZ) * 0.5_r8 + + ! bound in [0,1] + frac_rain = min(1.0_r8,max(0.0_r8,frac_rain)) + + end subroutine shr_precip_partition_rain_snow_ramp + +end module shr_precip_mod diff --git a/share/csm_share/shr/shr_reprosum_mod.F90 b/share/csm_share/shr/shr_reprosum_mod.F90 new file mode 100644 index 000000000000..54a289268963 --- /dev/null +++ b/share/csm_share/shr/shr_reprosum_mod.F90 @@ -0,0 +1,1426 @@ +module shr_reprosum_mod +!----------------------------------------------------------------------- +! +! Purpose: +! Compute reproducible global sums of a set of arrays across an MPI +! subcommunicator +! +! Methods: +! Compute using either or both a scalable, reproducible algorithm and a +! scalable, nonreproducible algorithm: +! * Reproducible (scalable): +! Convert to fixed point (integer vector representation) to enable +! reproducibility when using MPI_Allreduce +! * Alternative usually reproducible (scalable): +! Use parallel double-double algorithm due to Helen He and +! Chris Ding, based on David Bailey's/Don Knuth's DDPDD algorithm +! * Nonreproducible (scalable): +! Floating point and MPI_Allreduce based. +! If computing both reproducible and nonreproducible sums, compare +! these and report relative difference (if absolute difference +! less than sum) or absolute difference back to calling routine. +! +! Author: P. Worley (based on suggestions from J. White for fixed +! point algorithm and on He/Ding paper for ddpdd +! algorithm) +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!- use statements ------------------------------------------------------ +!----------------------------------------------------------------------- +#if ( defined noI8 ) + ! Workaround for when shr_kind_i8 is not supported. + use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i4 +#else + use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8 +#endif + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use shr_sys_mod, only: shr_sys_abort + use perf_mod + +!----------------------------------------------------------------------- +!- module boilerplate -------------------------------------------------- +!----------------------------------------------------------------------- + implicit none + private + +!----------------------------------------------------------------------- +!- include statements -------------------------------------------------- +!----------------------------------------------------------------------- +#include + + save + +!----------------------------------------------------------------------- +! Public interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + public :: & + shr_reprosum_setopts, &! set runtime options + shr_reprosum_calc, &! calculate distributed sum + shr_reprosum_tolExceeded ! utility function to check relative + ! differences against the tolerance + +!----------------------------------------------------------------------- +! Public data ---------------------------------------------------------- +!----------------------------------------------------------------------- + logical, public :: shr_reprosum_recompute = .false. + + real(r8), public :: shr_reprosum_reldiffmax = -1.0_r8 + +!----------------------------------------------------------------------- +! Private interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + private :: & + ddpdd, &! double-double sum routine + split_indices ! split indices among OMP threads + +!----------------------------------------------------------------------- +! Private data ---------------------------------------------------------- +!----------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! shr_reprosum_mod options + !---------------------------------------------------------------------------- + logical :: repro_sum_use_ddpdd = .false. + + CONTAINS + +! +!======================================================================== +! + subroutine shr_reprosum_setopts(repro_sum_use_ddpdd_in, & + repro_sum_rel_diff_max_in, & + repro_sum_recompute_in, & + repro_sum_master, & + repro_sum_logunit ) + +!----------------------------------------------------------------------- +! Purpose: Set runtime options +! Author: P. Worley +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + ! Use DDPDD algorithm instead of fixed precision algorithm + logical, intent(in), optional :: repro_sum_use_ddpdd_in + ! maximum permissible difference between reproducible and + ! nonreproducible sums + real(r8), intent(in), optional :: repro_sum_rel_diff_max_in + ! recompute using different algorithm when difference between + ! reproducible and nonreproducible sums is too great + logical, intent(in), optional :: repro_sum_recompute_in + ! flag indicating whether this process should output + ! log messages + logical, intent(in), optional :: repro_sum_master + ! unit number for log messages + integer, intent(in), optional :: repro_sum_logunit +!---------------------------Local Workspace----------------------------- + integer logunit ! unit number for log messages + logical master ! local master? + logical,save :: firstcall = .true. ! first call +!----------------------------------------------------------------------- + + if ( present(repro_sum_master) ) then + master = repro_sum_master + else + master = .false. + endif + + if ( present(repro_sum_logunit) ) then + logunit = repro_sum_logunit + else + logunit = s_logunit + endif + + if (.not. firstcall) then + write(logunit,*) 'shr_reprosum_setopts: ERROR can only be called once' + call shr_sys_abort('shr_reprosum_setopts ERROR: multiple calls') + endif + firstcall = .false. + + if ( present(repro_sum_use_ddpdd_in) ) then + repro_sum_use_ddpdd = repro_sum_use_ddpdd_in + endif + if ( present(repro_sum_rel_diff_max_in) ) then + shr_reprosum_reldiffmax = repro_sum_rel_diff_max_in + endif + if ( present(repro_sum_recompute_in) ) then + shr_reprosum_recompute = repro_sum_recompute_in + endif + if (master) then + if ( repro_sum_use_ddpdd ) then + write(logunit,*) 'SHR_REPROSUM_SETOPTS: ',& + 'Using double-double-based (scalable) usually reproducible ', & + 'distributed sum algorithm' + else + write(logunit,*) 'SHR_REPROSUM_SETOPTS: ',& + 'Using fixed-point-based (scalable) reproducible ', & + 'distributed sum algorithm' + endif + + if (shr_reprosum_reldiffmax >= 0._r8) then + write(logunit,*) ' ',& + 'with a maximum relative error tolerance of ', & + shr_reprosum_reldiffmax + if (shr_reprosum_recompute) then + write(logunit,*) ' ',& + 'If tolerance exceeded, sum is recomputed using ', & + 'a serial algorithm.' + else + write(logunit,*) ' ',& + 'If tolerance exceeded, fixed-precision is sum used ', & + 'but a warning is output.' + endif + else + write(logunit,*) ' ',& + 'and not comparing with floating point algorithms.' + endif + + endif + end subroutine shr_reprosum_setopts + +! +!======================================================================== +! + + subroutine shr_reprosum_calc (arr, arr_gsum, nsummands, dsummands, & + nflds, ddpdd_sum, & + arr_gbl_max, arr_gbl_max_out, & + arr_max_levels, arr_max_levels_out, & + gbl_max_nsummands, gbl_max_nsummands_out,& + gbl_count, repro_sum_validate, & + repro_sum_stats, rel_diff, commid ) +!---------------------------------------------------------------------- +! +! Purpose: +! Compute the global sum of each field in "arr" using the indicated +! communicator with a reproducible yet scalable implementation based +! on a fixed point algorithm. An alternative is to use an "almost +! always reproducible" floating point algorithm, as described below. +! +! The accuracy of the fixed point algorithm is controlled by the +! number of "levels" of integer expansion. The algorithm will calculate +! the number of levels that is required for the sum to be essentially +! exact. The optional parameter arr_max_levels can be used to override +! the calculated value. The optional parameter arr_max_levels_out can be +! used to return the values used. +! +! The algorithm also requires an upper bound on +! the maximum summand (in absolute value) for each field, and will +! calculate this internally. However, if the optional parameters +! arr_max_levels and arr_gbl_max are both set, then the algorithm will +! use the values in arr_gbl_max for the upper bounds instead. If these +! are not upper bounds, or if the upper bounds are not tight enough +! to achieve the requisite accuracy, and if the optional parameter +! repro_sum_validate is NOT set to .false., the algorithm will repeat the +! computation with appropriate upper bounds. If only arr_gbl_max is present, +! then the maxima are computed internally (and the specified values are +! ignored). The optional parameter arr_gbl_max_out can be +! used to return the values used. +! +! Finally, the algorithm requires an upper bound on the number of +! local summands across all processes. This will be calculated internally, +! using an MPI collective, but the value in the optional argument +! gbl_max_nsummands will be used instead if (1) it is present, (2) +! it is > 0, and (3) the maximum value and required number of levels +! are also specified. (If the maximum value is calculated, the same +! MPI collective is used to determine the maximum number of local +! summands.) The accuracy of the user-specified value is not checked. +! However, if set to < 1, the value will instead be calculated. If the +! optional parameter gbl_max_nsummands_out is present, then the value +! used (gbl_max_nsummands if >= 1; calculated otherwise) will be +! returned. +! +! If requested (by setting shr_reprosum_reldiffmax >= 0.0 and passing in +! the optional rel_diff parameter), results are compared with a +! nonreproducible floating point algorithm. +! +! Note that the cost of the algorithm is not strongly correlated with +! the number of levels, which primarily shows up as a (modest) increase +! in cost of the MPI_Allreduce as a function of vector length. Rather the +! cost is more a function of (a) the number of integers required to +! represent an individual summand and (b) the number of MPI_Allreduce +! calls. The number of integers required to represent an individual +! summand is 1 or 2 when using 8-byte integers for 8-byte real summands +! when the number of local summands is not too large. As the number of +! local summands increases, the number of integers required increases. +! The number of MPI_Allreduce calls is either 2 (specifying nothing) or +! 1 (specifying gbl_max_nsummands, arr_max_levels, and arr_gbl_max +! correctly). When specifying arr_max_levels and arr_gbl_max +! incorrectly, 3 or 4 MPI_Allreduce calls will be required. +! +! The alternative algorithm is a minor modification of a parallel +! implementation of David Bailey's routine DDPDD by Helen He +! and Chris Ding. Bailey uses the Knuth trick to implement quadruple +! precision summation of double precision values with 10 double +! precision operations. The advantage of this algorithm is that +! it requires a single MPI_Allreduce and is less expensive per summand +! than is the fixed precision algorithm. The disadvantage is that it +! is not guaranteed to be reproducible (though it is reproducible +! much more often than is the standard algorithm). This alternative +! is used when the optional parameter ddpdd_sum is set to .true. It is +! also used if the fixed precision algorithm radix assumption does not +! hold. +! +!---------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: nsummands ! number of local summands + integer, intent(in) :: dsummands ! declared first dimension + integer, intent(in) :: nflds ! number of fields + real(r8), intent(in) :: arr(dsummands,nflds) + ! input array + + real(r8), intent(out):: arr_gsum(nflds) + ! global means + + logical, intent(in), optional :: ddpdd_sum + ! use ddpdd algorithm instead + ! of fixed precision algorithm + + real(r8), intent(in), optional :: arr_gbl_max(nflds) + ! upper bound on max(abs(arr)) + + real(r8), intent(out), optional :: arr_gbl_max_out(nflds) + ! calculated upper bound on + ! max(abs(arr)) + + integer, intent(in), optional :: arr_max_levels(nflds) + ! maximum number of levels of + ! integer expansion to use + + integer, intent(out), optional :: arr_max_levels_out(nflds) + ! output of number of levels of + ! integer expansion to used + + integer, intent(in), optional :: gbl_max_nsummands + ! maximum of nsummand over all + ! processes + + integer, intent(out), optional :: gbl_max_nsummands_out + ! calculated maximum nsummands + ! over all processes + + integer, intent(in), optional :: gbl_count + ! was total number of summands; + ! now is ignored; use + ! gbl_max_nsummands instead + + logical, intent(in), optional :: repro_sum_validate + ! flag enabling/disabling testing that gmax and max_levels are + ! accurate/sufficient. Default is enabled. + + integer, intent(inout), optional :: repro_sum_stats(5) + ! increment running totals for + ! (1) one-reduction repro_sum + ! (2) two-reduction repro_sum + ! (3) both types in one call + ! (4) nonrepro_sum + ! (5) global max nsummands reduction + + real(r8), intent(out), optional :: rel_diff(2,nflds) + ! relative and absolute + ! differences between fixed + ! and floating point sums + + integer, intent(in), optional :: commid + ! MPI communicator + +! +! Local workspace +! + logical :: use_ddpdd_sum ! flag indicating whether to + ! use shr_reprosum_ddpdd or not + logical :: recompute ! flag indicating need to + ! determine gmax/gmin before + ! computing sum + logical :: validate ! flag indicating need to + ! verify gmax and max_levels + ! are accurate/sufficient + integer :: omp_nthreads ! number of OpenMP threads + integer :: mpi_comm ! MPI subcommunicator + integer :: tasks ! number of MPI processes + integer :: ierr ! MPI error return + integer :: ifld, isum, ithread ! loop variables + integer :: max_nsummands ! max nsummands over all processes + ! or threads (used in both ways) + + integer, allocatable :: isum_beg(:), isum_end(:) + ! range of summand indices for each + ! OpenMP thread + integer, allocatable :: arr_tlmin_exp(:,:) + ! per thread local exponent minima + integer, allocatable :: arr_tlmax_exp(:,:) + ! per thread local exponent maxima + integer :: arr_exp, arr_exp_tlmin, arr_exp_tlmax + ! summand exponent and working min/max + integer :: arr_lmin_exp(nflds) ! local exponent minima + integer :: arr_lmax_exp(nflds) ! local exponent maxima + integer :: arr_lextremes(0:nflds,2)! local exponent extrema + integer :: arr_gextremes(0:nflds,2)! global exponent extrema + + integer :: arr_gmax_exp(nflds) ! global exponents maxima + integer :: arr_gmin_exp(nflds) ! global exponents minima + integer :: arr_max_shift ! maximum safe exponent for + ! value < 1 (so that sum does + ! not overflow) + integer :: max_levels(nflds) ! maximum number of levels of + ! integer expansion to use + integer :: max_level ! maximum value in max_levels + integer :: gbl_max_red ! global max local sum reduction? (0/1) + integer :: repro_sum_fast ! 1 reduction repro_sum? (0/1) + integer :: repro_sum_slow ! 2 reduction repro_sum? (0/1) + integer :: repro_sum_both ! both fast and slow? (0/1) + integer :: nonrepro_sum ! nonrepro_sum? (0/1) + + real(r8) :: xmax_nsummands ! dble of max_nsummands + real(r8) :: arr_lsum(nflds) ! local sums + real(r8) :: arr_gsum_fast(nflds) ! global sum calculated using + ! fast, nonreproducible, + ! floating point alg. + real(r8) :: abs_diff ! absolute difference between + ! fixed and floating point + ! sums +#ifdef _OPENMP + integer omp_get_max_threads + external omp_get_max_threads +#endif +! +!----------------------------------------------------------------------- +! +! check whether should use shr_reprosum_ddpdd algorithm + use_ddpdd_sum = repro_sum_use_ddpdd + if ( present(ddpdd_sum) ) then + use_ddpdd_sum = ddpdd_sum + endif + +! check whether intrinsic-based algorithm will work on this system +! (requires floating point and integer bases to be the same) +! If not, always use ddpdd. + use_ddpdd_sum = use_ddpdd_sum .or. (radix(0._r8) /= radix(0_i8)) + +! initialize local statistics variables + gbl_max_red = 0 + repro_sum_fast = 0 + repro_sum_slow = 0 + repro_sum_both = 0 + nonrepro_sum = 0 + +! set MPI communicator + if ( present(commid) ) then + mpi_comm = commid + else + mpi_comm = MPI_COMM_WORLD + endif + call t_barrierf('sync_repro_sum',mpi_comm) + + if ( use_ddpdd_sum ) then + + call t_startf('shr_reprosum_ddpdd') + + call shr_reprosum_ddpdd(arr, arr_gsum, nsummands, dsummands, & + nflds, mpi_comm) + repro_sum_fast = 1 + + call t_stopf('shr_reprosum_ddpdd') + + else + + call t_startf('shr_reprosum_int') + +! get number of MPI tasks + call mpi_comm_size(mpi_comm, tasks, ierr) + +! get number of OpenMP threads +#ifdef _OPENMP + omp_nthreads = omp_get_max_threads() +#else + omp_nthreads = 1 +#endif + +! see if have sufficient information to not require max/min allreduce + recompute = .true. + validate = .false. + if ( present(arr_gbl_max) .and. present(arr_max_levels) ) then + recompute = .false. + +! setting lower bound on max_level*nflds to be 64 to improve OpenMP +! performance for loopb in shr_reprosum_int + max_level = (64/nflds) + 1 + do ifld=1,nflds + if ((arr_gbl_max(ifld) .ge. 0.0_r8) .and. & + (arr_max_levels(ifld) > 0)) then + + arr_gmax_exp(ifld) = exponent(arr_gbl_max(ifld)) + if (max_level < arr_max_levels(ifld)) & + max_level = arr_max_levels(ifld) + + else + recompute = .true. + endif + enddo + + if (.not. recompute) then + +! determine maximum number of summands in local phases of the +! algorithm + call t_startf("repro_sum_allr_max") + if ( present(gbl_max_nsummands) ) then + if (gbl_max_nsummands < 1) then + call mpi_allreduce (nsummands, max_nsummands, 1, & + MPI_INTEGER, MPI_MAX, mpi_comm, ierr) + gbl_max_red = 1 + else + max_nsummands = gbl_max_nsummands + endif + else + call mpi_allreduce (nsummands, max_nsummands, 1, & + MPI_INTEGER, MPI_MAX, mpi_comm, ierr) + gbl_max_red = 1 + endif + call t_stopf("repro_sum_allr_max") + +! determine maximum shift. Shift needs to be small enough that summation +! does not exceed maximum number of digits in i8. + +! if requested, return max_nsummands before it is redefined + if ( present( gbl_max_nsummands_out) ) then + gbl_max_nsummands_out = max_nsummands + endif + +! summing within each thread first + max_nsummands = (max_nsummands/omp_nthreads) + 1 +! then over threads and tasks + max_nsummands = max(max_nsummands, tasks*omp_nthreads) + + xmax_nsummands = dble(max_nsummands) + arr_max_shift = digits(0_i8) - (exponent(xmax_nsummands) + 1) + if (arr_max_shift < 2) then + call shr_sys_abort('repro_sum failed: number of summands too '// & + 'large for fixed precision algorithm' ) + endif + +! calculate sum + if (present(repro_sum_validate)) then + validate = repro_sum_validate + else + validate = .true. + endif + call shr_reprosum_int(arr, arr_gsum, nsummands, dsummands, & + nflds, arr_max_shift, arr_gmax_exp, & + arr_max_levels, max_level, validate, & + recompute, omp_nthreads, mpi_comm) + +! record statistics, etc. + repro_sum_fast = 1 + if (recompute) then + repro_sum_both = 1 + else +! if requested, return specified levels and upper bounds on maxima + if ( present(arr_max_levels_out) ) then + do ifld=1,nflds + arr_max_levels_out(ifld) = arr_max_levels(ifld) + enddo + endif + if ( present(arr_gbl_max_out) ) then + do ifld=1,nflds + arr_gbl_max_out(ifld) = arr_gbl_max(ifld) + enddo + endif + endif + endif + endif + +! do not have sufficient information; calculate global max/min and +! use to compute required number of levels + if (recompute) then + +! record statistic + repro_sum_slow = 1 + +! determine maximum and minimum (non-zero) summand values and +! maximum number of local summands + +! allocate thread-specific work space + allocate(arr_tlmax_exp(nflds,omp_nthreads)) + allocate(arr_tlmin_exp(nflds,omp_nthreads)) + allocate(isum_beg(omp_nthreads)) + allocate(isum_end(omp_nthreads)) + +! split summand index range over OpenMP threads + call split_indices(nsummands, omp_nthreads, isum_beg, isum_end) + +!$omp parallel do & +!$omp default(shared) & +!$omp private(ithread, ifld, isum, arr_exp, arr_exp_tlmin, arr_exp_tlmax) + do ithread=1,omp_nthreads + call t_startf('repro_sum_loopa') + do ifld=1,nflds + arr_exp_tlmin = MAXEXPONENT(1._r8) + arr_exp_tlmax = MINEXPONENT(1._r8) + do isum=isum_beg(ithread),isum_end(ithread) + if (arr(isum,ifld) .ne. 0.0_r8) then + arr_exp = exponent(arr(isum,ifld)) + arr_exp_tlmin = min(arr_exp,arr_exp_tlmin) + arr_exp_tlmax = max(arr_exp,arr_exp_tlmax) + endif + end do + arr_tlmin_exp(ifld,ithread) = arr_exp_tlmin + arr_tlmax_exp(ifld,ithread) = arr_exp_tlmax + end do + call t_stopf('repro_sum_loopa') + end do + + do ifld=1,nflds + arr_lmax_exp(ifld) = maxval(arr_tlmax_exp(ifld,:)) + arr_lmin_exp(ifld) = minval(arr_tlmin_exp(ifld,:)) + end do + deallocate(arr_tlmin_exp,arr_tlmax_exp,isum_beg,isum_end) + + arr_lextremes(0,:) = -nsummands + arr_lextremes(1:nflds,1) = -arr_lmax_exp(:) + arr_lextremes(1:nflds,2) = arr_lmin_exp(:) + call t_startf("repro_sum_allr_minmax") + call mpi_allreduce (arr_lextremes, arr_gextremes, 2*(nflds+1), & + MPI_INTEGER, MPI_MIN, mpi_comm, ierr) + call t_stopf("repro_sum_allr_minmax") + max_nsummands = -arr_gextremes(0,1) + arr_gmax_exp(:) = -arr_gextremes(1:nflds,1) + arr_gmin_exp(:) = arr_gextremes(1:nflds,2) + +! if a field is identically zero, arr_gmin_exp still equals MAXEXPONENT +! and arr_gmax_exp still equals MINEXPONENT. In this case, set +! arr_gmin_exp = arr_gmax_exp = MINEXPONENT + do ifld=1,nflds + arr_gmin_exp(ifld) = min(arr_gmax_exp(ifld),arr_gmin_exp(ifld)) + enddo + +! if requested, return upper bounds on observed maxima + if ( present(arr_gbl_max_out) ) then + do ifld=1,nflds + arr_gbl_max_out(ifld) = scale(1.0_r8,arr_gmax_exp(ifld)) + enddo + endif + +! if requested, return max_nsummands before it is redefined + if ( present( gbl_max_nsummands_out) ) then + gbl_max_nsummands_out = max_nsummands + endif + +! determine maximum shift (same as in previous branch, but with calculated +! max_nsummands). Shift needs to be small enough that summation does not +! exceed maximum number of digits in i8. + +! summing within each thread first + max_nsummands = (max_nsummands/omp_nthreads) + 1 +! then over threads and tasks + max_nsummands = max(max_nsummands, tasks*omp_nthreads) + + xmax_nsummands = dble(max_nsummands) + arr_max_shift = digits(0_i8) - (exponent(xmax_nsummands) + 1) + if (arr_max_shift < 2) then + call shr_sys_abort('repro_sum failed: number of summands too '// & + 'large for fixed precision algorithm' ) + endif + +! determine maximum number of levels required for each field +! ((digits(0_i8) + (arr_gmax_exp(ifld)-arr_gmin_exp(ifld))) / arr_max_shift) +! + 1 because first truncation probably does not involve a maximal shift +! + 1 to guarantee that the integer division rounds up (not down) +! (setting lower bound on max_level*nflds to be 64 to improve OpenMP +! performance for loopb in shr_reprosum_int) + max_level = (64/nflds) + 1 + do ifld=1,nflds + max_levels(ifld) = 2 + & + ((digits(0_i8) + (arr_gmax_exp(ifld)-arr_gmin_exp(ifld))) & + / arr_max_shift) + if ( present(arr_max_levels) .and. (.not. validate) ) then +! if validate true, then computation with arr_max_levels failed +! previously + if ( arr_max_levels(ifld) > 0 ) then + max_levels(ifld) = & + min(arr_max_levels(ifld),max_levels(ifld)) + endif + endif + if (max_level < max_levels(ifld)) & + max_level = max_levels(ifld) + enddo + +! if requested, return calculated levels + if ( present(arr_max_levels_out) ) then + do ifld=1,nflds + arr_max_levels_out(ifld) = max_levels(ifld) + enddo + endif + +! calculate sum + validate = .false. + call shr_reprosum_int(arr, arr_gsum, nsummands, dsummands, nflds, & + arr_max_shift, arr_gmax_exp, max_levels, & + max_level, validate, recompute, & + omp_nthreads, mpi_comm) + + endif + + call t_stopf('shr_reprosum_int') + + endif + +! compare fixed and floating point results + if ( present(rel_diff) ) then + if (shr_reprosum_reldiffmax >= 0.0_r8) then + + call t_barrierf('sync_nonrepro_sum',mpi_comm) + call t_startf('nonrepro_sum') +! record statistic + nonrepro_sum = 1 +! compute nonreproducible sum + arr_lsum(:) = 0._r8 +!$omp parallel do & +!$omp default(shared) & +!$omp private(ifld, isum) + do ifld=1,nflds + do isum=1,nsummands + arr_lsum(ifld) = arr(isum,ifld) + arr_lsum(ifld) + end do + end do + + call mpi_allreduce (arr_lsum, arr_gsum_fast, nflds, & + MPI_REAL8, MPI_SUM, mpi_comm, ierr) + + call t_stopf('nonrepro_sum') + +! determine differences +!$omp parallel do & +!$omp default(shared) & +!$omp private(ifld, abs_diff) + do ifld=1,nflds + abs_diff = abs(arr_gsum_fast(ifld)-arr_gsum(ifld)) + if (abs(arr_gsum(ifld)) > abs_diff) then + rel_diff(1,ifld) = abs_diff/abs(arr_gsum(ifld)) + else + rel_diff(1,ifld) = abs_diff + endif + rel_diff(2,ifld) = abs_diff + enddo + else + rel_diff(:,:) = 0.0_r8 + endif + endif + +! return statistics + if ( present(repro_sum_stats) ) then + repro_sum_stats(1) = repro_sum_stats(1) + repro_sum_fast + repro_sum_stats(2) = repro_sum_stats(2) + repro_sum_slow + repro_sum_stats(3) = repro_sum_stats(3) + repro_sum_both + repro_sum_stats(4) = repro_sum_stats(4) + nonrepro_sum + repro_sum_stats(5) = repro_sum_stats(5) + gbl_max_red + endif + + + end subroutine shr_reprosum_calc + +! +!======================================================================== +! + + subroutine shr_reprosum_int (arr, arr_gsum, nsummands, dsummands, nflds, & + arr_max_shift, arr_gmax_exp, max_levels, & + max_level, validate, recompute, & + omp_nthreads, mpi_comm ) +!---------------------------------------------------------------------- +! +! Purpose: +! Compute the global sum of each field in "arr" using the indicated +! communicator with a reproducible yet scalable implementation based +! on a fixed point algorithm. The accuracy of the fixed point algorithm +! is controlled by the number of "levels" of integer expansion, the +! maximum value of which is specified by max_level. +! +!---------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: nsummands ! number of local summands + integer, intent(in) :: dsummands ! declared first dimension + integer, intent(in) :: nflds ! number of fields + integer, intent(in) :: arr_max_shift ! maximum safe exponent for + ! value < 1 (so that sum + ! does not overflow) + integer, intent(in) :: arr_gmax_exp(nflds) + ! exponents of global maxima + integer, intent(in) :: max_levels(nflds) + ! maximum number of levels + ! of integer expansion + integer, intent(in) :: max_level ! maximum value in + ! max_levels + integer, intent(in) :: omp_nthreads ! number of OpenMP threads + integer, intent(in) :: mpi_comm ! MPI subcommunicator + + real(r8), intent(in) :: arr(dsummands,nflds) + ! input array + + logical, intent(in):: validate + ! flag indicating that accuracy of solution generated from + ! arr_gmax_exp and max_levels should be tested + + logical, intent(out):: recompute + ! flag indicating that either the upper bounds are inaccurate, + ! or max_levels and arr_gmax_exp do not generate accurate + ! enough sums + + real(r8), intent(out):: arr_gsum(nflds) ! global means +! +! Local workspace +! + integer, parameter :: max_jlevel = & + 1 + (digits(0_i8)/digits(0.0_r8)) + + integer(i8) :: i8_arr_tlsum_level(0:max_level,nflds,omp_nthreads) + ! integer vector representing local + ! sum (per thread, per field) + integer(i8) :: i8_arr_lsum_level((max_level+3)*nflds) + ! integer vector representing local + ! sum + integer(i8) :: i8_arr_level ! integer part of summand for current + ! expansion level + integer(i8) :: i8_arr_gsum_level((max_level+3)*nflds) + ! integer vector representing global + ! sum + integer(i8) :: IX_8 ! integer representation of current + ! jlevels of X_8 ('part' of + ! i8_arr_gsum_level) + integer(i8) :: i8_sign ! sign global sum + integer(i8) :: i8_radix ! radix for i8 variables + + integer :: max_error(nflds,omp_nthreads) + ! accurate upper bound on data? + integer :: not_exact(nflds,omp_nthreads) + ! max_levels sufficient to + ! capture all digits? + integer :: isum_beg(omp_nthreads), isum_end(omp_nthreads) + ! range of summand indices for each + ! OpenMP thread + integer :: ifld, isum, ithread + ! loop variables + integer :: arr_exp ! exponent of summand + integer :: arr_shift ! exponent used to generate integer + ! for current expansion level + integer :: ilevel ! current integer expansion level + integer :: offset(nflds) ! beginning location in + ! i8_arr_{g,l}sum_level for integer + ! expansion of current ifld + integer :: voffset ! modification to offset used to + ! include validation metrics + integer :: ioffset ! offset(ifld) + integer :: jlevel ! number of floating point 'pieces' + ! extracted from a given i8 integer + integer :: ierr ! MPI error return + integer :: LX(max_jlevel) ! exponent of X_8 (see below) + integer :: veclth ! total length of i8_arr_lsum_level + integer :: sum_digits ! lower bound on number of significant + ! in integer expansion of sum + integer :: curr_exp ! exponent of partial sum during + ! reconstruction from integer vector + integer :: corr_exp ! exponent of current summand in + ! reconstruction from integer vector + + real(r8) :: arr_frac ! fraction of summand + real(r8) :: arr_remainder ! part of summand remaining after + ! current level of integer expansion + real(r8) :: X_8(max_jlevel) ! r8 vector representation of current + ! i8_arr_gsum_level + real(r8) :: RX_8 ! r8 representation of difference + ! between current i8_arr_gsum_level + ! and current jlevels of X_8 + ! (== IX_8). Also used in final + ! scaling step + + logical :: first ! flag used to indicate that just + ! beginning reconstruction of sum + ! from integer vector + +! +!----------------------------------------------------------------------- +! Save radix of i8 variables in an i8 variable + i8_radix = radix(IX_8) + +! If validating upper bounds, reserve space for validation metrics +! In both cases, reserve an extra level for overflow from the top level + if (validate) then + voffset = 3 + else + voffset = 1 + endif + +! compute offsets for each field + offset(1) = voffset + do ifld=2,nflds + offset(ifld) = offset(ifld-1) & + + (max_levels(ifld-1) + voffset) + enddo + veclth = offset(nflds) + max_levels(nflds) + +! split summand index range over OpenMP threads + call split_indices(nsummands, omp_nthreads, isum_beg, isum_end) + +! convert local summands to vector of integers and sum +! (Using scale instead of set_exponent because arr_remainder may not be +! "normal" after level 1 calculation) + i8_arr_lsum_level(:) = 0_i8 + +!$omp parallel do & +!$omp default(shared) & +!$omp private(ithread, ifld, ioffset, isum, arr_frac, arr_exp, & +!$omp arr_shift, ilevel, i8_arr_level, arr_remainder, RX_8, IX_8) + do ithread=1,omp_nthreads + call t_startf('repro_sum_loopb') + do ifld=1,nflds + ioffset = offset(ifld) + + max_error(ifld,ithread) = 0 + not_exact(ifld,ithread) = 0 + + i8_arr_tlsum_level(:,ifld,ithread) = 0_i8 + do isum=isum_beg(ithread),isum_end(ithread) + arr_remainder = 0.0_r8 + + if (arr(isum,ifld) .ne. 0.0_r8) then + arr_exp = exponent(arr(isum,ifld)) + arr_frac = fraction(arr(isum,ifld)) + +! test that global maximum upper bound is an upper bound + if (arr_exp > arr_gmax_exp(ifld)) then + max_error(ifld,ithread) = 1 + exit + endif + +! calculate first shift + arr_shift = arr_max_shift - (arr_gmax_exp(ifld)-arr_exp) + +! determine first (probably) nonzero level (assuming initial fraction is +! 'normal' - algorithm still works if this is not true) +! NOTE: this is critical; scale will set to zero if min exponent is too small. + if (arr_shift < 1) then + ilevel = (1 + (arr_gmax_exp(ifld)-arr_exp))/arr_max_shift + arr_shift = ilevel*arr_max_shift - (arr_gmax_exp(ifld)-arr_exp) + + do while (arr_shift < 1) + arr_shift = arr_shift + arr_max_shift + ilevel = ilevel + 1 + enddo + else + ilevel = 1 + endif + + if (ilevel .le. max_levels(ifld)) then +! apply first shift/truncate, add it to the relevant running +! sum, and calculate the remainder. + arr_remainder = scale(arr_frac,arr_shift) + i8_arr_level = int(arr_remainder,i8) + i8_arr_tlsum_level(ilevel,ifld,ithread) = & + i8_arr_tlsum_level(ilevel,ifld,ithread) + i8_arr_level + arr_remainder = arr_remainder - i8_arr_level + +! while the remainder is non-zero, continue to shift, truncate, +! sum, and calculate new remainder + do while ((arr_remainder .ne. 0.0_r8) & + .and. (ilevel < max_levels(ifld))) + ilevel = ilevel + 1 + arr_remainder = scale(arr_remainder,arr_max_shift) + i8_arr_level = int(arr_remainder,i8) + i8_arr_tlsum_level(ilevel,ifld,ithread) = & + i8_arr_tlsum_level(ilevel,ifld,ithread) + i8_arr_level + arr_remainder = arr_remainder - i8_arr_level + enddo + + endif + endif + + if (arr_remainder .ne. 0.0_r8) then + not_exact(ifld,ithread) = 1 + endif + + enddo + +! postprocess integer vector to eliminate potential for overlap in the following +! sums over threads and processes: if value larger than or equal to +! (radix(IX_8)**arr_max_shift), add this 'overlap' to next larger integer in +! vector, resulting in nonoverlapping ranges for each component. Note that +! "ilevel-1==0" corresponds to an extra level used to guarantee that the sums +! over threads and processes do not overflow for ilevel==1. + do ilevel=max_levels(ifld),1,-1 + RX_8 = i8_arr_tlsum_level(ilevel,ifld,ithread) + IX_8 = int(scale(RX_8,-arr_max_shift),i8) + if (IX_8 .ne. 0_i8) then + i8_arr_tlsum_level(ilevel-1,ifld,ithread) = & + i8_arr_tlsum_level(ilevel-1,ifld,ithread) + IX_8 + IX_8 = IX_8*(i8_radix**arr_max_shift) + i8_arr_tlsum_level(ilevel,ifld,ithread) = & + i8_arr_tlsum_level(ilevel,ifld,ithread) - IX_8 + endif + enddo + enddo + call t_stopf('repro_sum_loopb') + enddo + +! sum contributions from different threads + do ifld=1,nflds + ioffset = offset(ifld) + do ithread = 1,omp_nthreads + do ilevel = 0,max_levels(ifld) + i8_arr_lsum_level(ioffset+ilevel) = & + i8_arr_lsum_level(ioffset+ilevel) & + + i8_arr_tlsum_level(ilevel,ifld,ithread) + enddo + enddo + enddo + +! record if upper bound was inaccurate or if level expansion stopped +! before full accuracy was achieved + if (validate) then + do ifld=1,nflds + ioffset = offset(ifld) + i8_arr_lsum_level(ioffset-voffset+1) = maxval(max_error(ifld,:)) + i8_arr_lsum_level(ioffset-voffset+2) = maxval(not_exact(ifld,:)) + enddo + endif + +! sum integer vector element-wise +#if ( defined noI8 ) + ! Workaround for when shr_kind_i8 is not supported. + call t_startf("repro_sum_allr_i4") + call mpi_allreduce (i8_arr_lsum_level, i8_arr_gsum_level, & + veclth, MPI_INTEGER, MPI_SUM, mpi_comm, ierr) + call t_stopf("repro_sum_allr_i4") +#else + call t_startf("repro_sum_allr_i8") + call mpi_allreduce (i8_arr_lsum_level, i8_arr_gsum_level, & + veclth, MPI_INTEGER8, MPI_SUM, mpi_comm, ierr) + call t_stopf("repro_sum_allr_i8") +#endif + +! Construct global sum from integer vector representation: +! 1) arr_max_shift is the shift applied to fraction(arr_gmax) . +! When shifting back, need to "add back in" true arr_gmax exponent. This was +! removed implicitly by working only with the fraction . +! 2) want to add levels into sum in reverse order (smallest to largest). However, +! even this can generate floating point rounding errors if signs of integers +! alternate. To avoid this, do some arithmetic with integer vectors so that all +! components have the same sign. This should keep relative difference between +! using different integer sizes (e.g. i8 and i4) to machine epsilon +! 3) assignment to X_8 will usually lose accuracy since maximum integer +! size is greater than the max number of 'digits' in r8 value (if xmax_nsummands +! correction not very large). Calculate remainder and add in first (since +! smaller). One correction is sufficient for r8 (53 digits) and i8 (63 digits). +! For r4 (24 digits) may need to correct twice. Code is written in a general +! fashion, to work no matter how many corrections are necessary (assuming +! max_jlevel parameter calculation is correct). + + recompute = .false. + do ifld=1,nflds + arr_gsum(ifld) = 0.0_r8 + ioffset = offset(ifld) + +! if validate is .true., test whether the summand upper bound +! was exceeded on any of the processes + if (validate) then + if (i8_arr_gsum_level(ioffset-voffset+1) .ne. 0_i8) then + recompute = .true. + endif + endif + + if (.not. recompute) then + +! preprocess integer vector: +! a) if value larger than or equal to (radix(IX_8)**arr_max_shift), add this 'overlap' +! to next larger integer in vector, resulting in nonoverlapping ranges for each +! component. Note that have "ilevel-1=0" level here as described above. + do ilevel=max_levels(ifld),1,-1 + RX_8 = i8_arr_gsum_level(ioffset+ilevel) + IX_8 = int(scale(RX_8,-arr_max_shift),i8) + if (IX_8 .ne. 0_i8) then + i8_arr_gsum_level(ioffset+ilevel-1) = i8_arr_gsum_level(ioffset+ilevel-1) & + + IX_8 + IX_8 = IX_8*(i8_radix**arr_max_shift) + i8_arr_gsum_level(ioffset+ilevel) = i8_arr_gsum_level(ioffset+ilevel) & + - IX_8 + endif + enddo +! b) subtract +/- 1 from larger and add +/- 1 to smaller when necessary +! so that all vector components have the same sign (eliminating loss +! of accuracy arising from difference of large values when +! reconstructing r8 sum from integer vector) + ilevel = 0 + do while ((i8_arr_gsum_level(ioffset+ilevel) .eq. 0_i8) & + .and. (ilevel < max_levels(ifld))) + ilevel = ilevel + 1 + enddo +! + if (ilevel < max_levels(ifld)) then + if (i8_arr_gsum_level(ioffset+ilevel) > 0_i8) then + i8_sign = 1_i8 + else + i8_sign = -1_i8 + endif + do jlevel=ilevel,max_levels(ifld)-1 + if (sign(1_i8,i8_arr_gsum_level(ioffset+jlevel)) & + .ne. sign(1_i8,i8_arr_gsum_level(ioffset+jlevel+1))) then + i8_arr_gsum_level(ioffset+jlevel) = i8_arr_gsum_level(ioffset+jlevel) & + - i8_sign + i8_arr_gsum_level(ioffset+jlevel+1) = i8_arr_gsum_level(ioffset+jlevel+1) & + + i8_sign*(i8_radix**arr_max_shift) + endif + enddo + endif + +! start with maximum shift, and work up to larger values + arr_shift = arr_gmax_exp(ifld) & + - max_levels(ifld)*arr_max_shift + curr_exp = 0 + first = .true. + do ilevel=max_levels(ifld),0,-1 + + if (i8_arr_gsum_level(ioffset+ilevel) .ne. 0_i8) then + jlevel = 1 + +! r8 representation of higher order bits in integer + X_8(jlevel) = i8_arr_gsum_level(ioffset+ilevel) + LX(jlevel) = exponent(X_8(jlevel)) + +! calculate remainder + IX_8 = int(X_8(jlevel),i8) + RX_8 = (i8_arr_gsum_level(ioffset+ilevel) - IX_8) + +! repeat using remainder + do while (RX_8 .ne. 0.0_r8) + jlevel = jlevel + 1 + X_8(jlevel) = RX_8 + LX(jlevel) = exponent(RX_8) + IX_8 = IX_8 + int(RX_8,i8) + RX_8 = (i8_arr_gsum_level(ioffset+ilevel) - IX_8) + enddo + +! add in contributions, smaller to larger, rescaling for each +! addition to guarantee that exponent of working summand is always +! larger than minexponent + do while (jlevel > 0) + if (first) then + curr_exp = LX(jlevel) + arr_shift + arr_gsum(ifld) = fraction(X_8(jlevel)) + first = .false. + else + corr_exp = curr_exp - (LX(jlevel) + arr_shift) + arr_gsum(ifld) = fraction(X_8(jlevel)) & + + scale(arr_gsum(ifld),corr_exp) + curr_exp = LX(jlevel) + arr_shift + endif + jlevel = jlevel - 1 + enddo + + endif + + arr_shift = arr_shift + arr_max_shift + enddo + +! apply final exponent correction, scaling first if exponent is too small +! to apply directly + corr_exp = curr_exp + exponent(arr_gsum(ifld)) + if (corr_exp .ge. MINEXPONENT(1._r8)) then + arr_gsum(ifld) = set_exponent(arr_gsum(ifld),corr_exp) + else + RX_8 = set_exponent(arr_gsum(ifld), & + corr_exp-MINEXPONENT(1._r8)) + arr_gsum(ifld) = scale(RX_8,MINEXPONENT(1._r8)) + endif + +! if validate is .true. and some precision lost, test whether 'too much' +! was lost, due to too loose an upper bound, too stringent a limit on number +! of levels of expansion, cancellation, .... Calculated by comparing lower +! bound on number of sigificant digits with number of digits in 1.0_r8 . + if (validate) then + if (i8_arr_gsum_level(ioffset-voffset+2) .ne. 0_i8) then + +! find first nonzero level and use exponent for this level, then assume all +! subsequent levels contribute arr_max_shift digits. + sum_digits = 0 + do ilevel=0,max_levels(ifld) + if (sum_digits .eq. 0) then + if (i8_arr_gsum_level(ioffset+ilevel) .ne. 0_i8) then + X_8(1) = i8_arr_gsum_level(ioffset+ilevel) + LX(1) = exponent(X_8(1)) + sum_digits = LX(1) + endif + else + sum_digits = sum_digits + arr_max_shift + endif + enddo + + if (sum_digits < digits(1.0_r8)) then + recompute = .true. + endif + endif + endif + + endif + + enddo + + + end subroutine shr_reprosum_int + +! +!======================================================================== +! + + logical function shr_reprosum_tolExceeded (name, nflds, master, & + logunit, rel_diff ) +!---------------------------------------------------------------------- +! +! Purpose: +! Test whether distributed sum exceeds tolerance and print out a +! warning message. +! +!---------------------------------------------------------------------- +! +! Arguments +! + character(len=*), intent(in) :: name ! distributed sum identifier + integer, intent(in) :: nflds ! number of fields + logical, intent(in) :: master ! process that will write + ! warning messages? + integer, optional, intent(in) :: logunit! unit warning messages + ! written to + real(r8), intent(in) :: rel_diff(2,nflds) + ! relative and absolute + ! differences between fixed + ! and floating point sums + +! +! Local workspace +! + integer :: llogunit ! local log unit + integer :: ifld ! field index + integer :: exceeds_limit ! number of fields whose + ! sum exceeds tolerance + real(r8) :: max_rel_diff ! maximum relative difference + integer :: max_rel_diff_idx ! field index for max. rel. diff. + real(r8) :: max_abs_diff ! maximum absolute difference + integer :: max_abs_diff_idx ! field index for max. abs. diff. +! +!----------------------------------------------------------------------- +! + shr_reprosum_tolExceeded = .false. + if (shr_reprosum_reldiffmax < 0.0_r8) return + + if ( present(logunit) ) then + llogunit = logunit + else + llogunit = s_logunit + endif + + ! check that "fast" reproducible sum is accurate enough. + exceeds_limit = 0 + max_rel_diff = 0.0_r8 + max_abs_diff = 0.0_r8 + do ifld=1,nflds + if (rel_diff(1,ifld) > shr_reprosum_reldiffmax) then + exceeds_limit = exceeds_limit + 1 + if (rel_diff(1,ifld) > max_rel_diff) then + max_rel_diff = rel_diff(1,ifld) + max_rel_diff_idx = ifld + endif + if (rel_diff(2,ifld) > max_abs_diff) then + max_abs_diff = rel_diff(2,ifld) + max_abs_diff_idx = ifld + endif + endif + enddo + + if (exceeds_limit > 0) then + if (master) then + write(llogunit,*) trim(name), & + ': difference in fixed and floating point sums ', & + ' exceeds tolerance in ', exceeds_limit, & + ' fields.' + write(llogunit,*) ' Maximum relative diff: (rel)', & + rel_diff(1,max_rel_diff_idx), ' (abs) ', & + rel_diff(2,max_rel_diff_idx) + write(llogunit,*) ' Maximum absolute diff: (rel)', & + rel_diff(1,max_abs_diff_idx), ' (abs) ', & + rel_diff(2,max_abs_diff_idx) + endif + shr_reprosum_tolExceeded = .true. + endif + + + end function shr_reprosum_tolExceeded + +! +!======================================================================== +! + + subroutine shr_reprosum_ddpdd (arr, arr_gsum, nsummands, dsummands, & + nflds, mpi_comm ) +!---------------------------------------------------------------------- +! +! Purpose: +! Compute the global sum of each field in "arr" using the indicated +! communicator with a reproducible yet scalable implementation based +! on He and Ding's implementation of the double-double algorithm. +! +!---------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: nsummands ! number of local summands + integer, intent(in) :: dsummands ! declared first dimension + integer, intent(in) :: nflds ! number of fields + real(r8), intent(in) :: arr(dsummands,nflds) + ! input array + integer, intent(in) :: mpi_comm ! MPI subcommunicator + + real(r8), intent(out):: arr_gsum(nflds) + ! global sums + +! +! Local workspace +! + integer :: old_cw ! for x86 processors, save + ! current arithmetic mode + integer :: ifld, isum ! loop variables + integer :: ierr ! MPI error return + + real(r8) :: e, t1, t2 ! temporaries + complex(r8) :: arr_lsum_dd(nflds) ! local sums (in double-double + ! format) + complex(r8) :: arr_gsum_dd(nflds) ! global sums (in double-double + ! format) + + integer, save :: mpi_sumdd + logical, save :: first_time = .true. + +! +!----------------------------------------------------------------------- +! + call shr_reprosumx86_fix_start (old_cw) + + if (first_time) then + call mpi_op_create(ddpdd, .true., mpi_sumdd, ierr) + first_time = .false. + endif + + do ifld=1,nflds + arr_lsum_dd(ifld) = (0.0_r8,0.0_r8) + + do isum=1,nsummands + + ! Compute arr(isum,ifld) + arr_lsum_dd(ifld) using Knuth''s + ! trick. + t1 = arr(isum,ifld) + real(arr_lsum_dd(ifld)) + e = t1 - arr(isum,ifld) + t2 = ((real(arr_lsum_dd(ifld)) - e) & + + (arr(isum,ifld) - (t1 - e))) & + + aimag(arr_lsum_dd(ifld)) + + ! The result is t1 + t2, after normalization. + arr_lsum_dd(ifld) = cmplx ( t1 + t2, t2 - ((t1 + t2) - t1), r8 ) + enddo + + enddo + + call mpi_allreduce (arr_lsum_dd, arr_gsum_dd, nflds, & + MPI_COMPLEX16, mpi_sumdd, mpi_comm, ierr) + do ifld=1,nflds + arr_gsum(ifld) = real(arr_gsum_dd(ifld)) + enddo + + call shr_reprosumx86_fix_end (old_cw) + + end subroutine shr_reprosum_ddpdd +! +!----------------------------------------------------------------------- +! + subroutine DDPDD (dda, ddb, len, itype) +!---------------------------------------------------------------------- +! +! Purpose: +! Modification of original codes written by David H. Bailey +! This subroutine computes ddb(i) = dda(i)+ddb(i) +! +!---------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: len ! array length + complex(r8), intent(in) :: dda(len) ! input + complex(r8), intent(inout) :: ddb(len) ! result + integer, intent(in) :: itype ! unused +! +! Local workspace +! + real(r8) e, t1, t2 + integer i +! +!----------------------------------------------------------------------- +! + do i = 1, len +! Compute dda + ddb using Knuth's trick. + t1 = real(dda(i)) + real(ddb(i)) + e = t1 - real(dda(i)) + t2 = ((real(ddb(i)) - e) + (real(dda(i)) - (t1 - e))) & + + aimag(dda(i)) + aimag(ddb(i)) + +! The result is t1 + t2, after normalization. + ddb(i) = cmplx ( t1 + t2, t2 - ((t1 + t2) - t1), r8 ) + enddo + + + end subroutine DDPDD +! +!----------------------------------------------------------------------- +! + subroutine split_indices(total,num_pieces,ibeg,iend) +!---------------------------------------------------------------------- +! +! Purpose: +! Split range into 'num_pieces' +! +!---------------------------------------------------------------------- +! +! Arguments +! + integer, intent(in) :: total + integer, intent(in) :: num_pieces + integer, intent(out) :: ibeg(num_pieces), iend(num_pieces) +! +! Local workspace +! + integer :: itmp1, itmp2, ioffset, i +! +!----------------------------------------------------------------------- +! + itmp1 = total/num_pieces + itmp2 = mod(total,num_pieces) + ioffset = 0 + do i=1,itmp2 + ibeg(i) = ioffset + 1 + iend(i) = ioffset + (itmp1+1) + ioffset = iend(i) + enddo + do i=itmp2+1,num_pieces + ibeg(i) = ioffset + 1 + if (ibeg(i) > total) then + iend(i) = ibeg(i) - 1 + else + iend(i) = ioffset + itmp1 + ioffset = iend(i) + endif + enddo + + end subroutine split_indices +! +!======================================================================== +! +end module shr_reprosum_mod diff --git a/share/csm_share/shr/shr_reprosumx86.c b/share/csm_share/shr/shr_reprosumx86.c new file mode 100644 index 000000000000..aa200b00eaa1 --- /dev/null +++ b/share/csm_share/shr/shr_reprosumx86.c @@ -0,0 +1,83 @@ +/* + * src/x86.c + * + * This work was supported by the Director, Office of Science, Division + * of Mathematical, Information, and Computational Sciences of the + * U.S. Department of Energy under contract number DE-AC03-76SF00098. + * + * Copyright (c) 2000-2001 + * + * Contains functions to set and restore the round-to-double flag in the + * control word of a x86 FPU. + */ + +#define _NO_CHANGE 0 +#define _UPPER_CASE 1 +#define _ADD_UNDERSCORE 2 +#define _ADD_TWO_UNDERSCORES 3 + +#ifdef FORTRANUNDERSCORE +#define NAMING _ADD_UNDERSCORE +#endif + +#ifdef FORTRANDOUBLEUNDERSCORE +#define NAMING _ADD_TWO_UNDERSCORES +#endif + +#ifdef FORTRANCAPS +#define NAMING _UPPER_CASE +#endif + +#ifndef NAMING +#define NAMING _NO_CHANGE +#endif + +#if (NAMING == _ADD_UNDERSCORE) +#define shr_reprosumx86_fix_start shr_reprosumx86_fix_start_ +#define shr_reprosumx86_fix_end shr_reprosumx86_fix_end_ +#endif + +#if (NAMING == _ADD_TWO_UNDERSCORES) +#define shr_reprosumx86_fix_start shr_reprosumx86_fix_start__ +#define shr_reprosumx86_fix_end shr_reprosumx86_fix_end__ +#endif + +#if (NAMING == _UPPER_CASE) +#define shr_reprosumx86_fix_start SHR_REPROSUMX86_FIX_START +#define shr_reprosumx86_fix_end SHR_REPROSUMX86_FIX_END +#endif + +#ifdef x86 +#ifndef _FPU_GETCW +#define _FPU_GETCW(x) asm volatile ("fnstcw %0":"=m" (x)); +#endif + +#ifndef _FPU_SETCW +#define _FPU_SETCW(x) asm volatile ("fldcw %0": :"m" (x)); +#endif + +#ifndef _FPU_EXTENDED +#define _FPU_EXTENDED 0x0300 +#endif + +#ifndef _FPU_DOUBLE +#define _FPU_DOUBLE 0x0200 +#endif +#endif /* x86 */ + +void shr_reprosumx86_fix_start(unsigned short *old_cw) { +#ifdef x86 + unsigned short new_cw; + + _FPU_GETCW(*old_cw); + new_cw = (*old_cw & ~_FPU_EXTENDED) | _FPU_DOUBLE; + _FPU_SETCW(new_cw); +#endif +} + +void shr_reprosumx86_fix_end(unsigned short *old_cw) { +#ifdef x86 + _FPU_SETCW(*old_cw); +#endif +} + diff --git a/share/csm_share/shr/shr_scam_mod.F90 b/share/csm_share/shr/shr_scam_mod.F90 new file mode 100644 index 000000000000..b7f96b867994 --- /dev/null +++ b/share/csm_share/shr/shr_scam_mod.F90 @@ -0,0 +1,953 @@ +!=============================================================================== +! SVN $Id: +! SVN $URL: +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_scam_mod.F90 --- Module to handle single column mode share routines. +! +! !DESCRIPTION: +! Routines needed by drv or several component models for running in single column mode +! +! !REVISION HISTORY: +! 2010 Nov 05 - E. Kluzek ---- add PIO and file interfaces for getCloseLatLon +! 2007 Sep 14 - B. Kauffman - svn checkin +! 2007 Aug 29 - J. Truesdale - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_scam_mod + +! !USES: + + use shr_kind_mod ! defines kinds + use shr_sys_mod ! system calls + use shr_file_mod ! file utilities + use shr_kind_mod, only : R8=>SHR_KIND_R8,IN=>SHR_KIND_IN,CL=>SHR_KIND_CL + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_log_mod, only : s_logunit => shr_log_Unit + + implicit none + + private ! By default everything is private to this module + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_scam_getCloseLatLon ! return lat and lon point/index + public :: shr_scam_checkSurface ! check grid fraction in focndomain dataset + + interface shr_scam_getCloseLatLon + module procedure shr_scam_getCloseLatLonNC + module procedure shr_scam_getCloseLatLonPIO + module procedure shr_scam_getCloseLatLonFile + end interface + +! !PUBLIC DATA MEMBERS: + + ! no public data members + +!EOP + +! !PRIVATE MEMBER FUNCTIONS: + + private :: is_latlon ! Check if variable name is a latitude or longitude + private :: get_close ! Retrieve the closest lat/lon + private :: get_latlonindices ! Get the start/count indices to retreive lat or long + +! !PRIVATE DATA MEMBERS: + + save + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_scam_getCloseLatLonNC +! +! !DESCRIPTION: +! routine to search in netcdf file and return lat and lon point/index closest to target point +! +! !REVISION HISTORY: +! 2010 Nov 05 - E. Kluzek ---- Use is_latlon/get_close/get_latlonindices routines +! 2007 Aug 29 - J. Truesdale - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_scam_getCloseLatLonNC(ncid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found, rc) +! !USES: + use netcdf + use shr_ncread_mod, only: shr_ncread_handleErr + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(IN),intent(in) :: ncid ! netcdf id + real (R8),intent(in) :: targetLat ! find closest latitude to this point + real (R8),intent(in) :: targetLon ! find closest longitude to this point + real (R8),intent(out) :: closeLat ! returned close lat + real (R8),intent(out) :: closeLon ! returned close lon + integer(IN),intent(out) :: closeLatIdx ! index of returned lat point + integer(IN),intent(out) :: closeLonIdx ! index of returned lon point + logical, optional, intent(out) :: found ! if found answer (will abort if found NOT sent and + ! it couldn't find the lat/lon dimensions) + integer, optional, intent(out) :: rc ! Return code + +!EOP + + + !----- local variables ----- + real (R8),allocatable :: lats(:),lons(:) + integer(IN) :: rcode ! netCDF routine return code + integer(IN) :: i + integer(IN) :: len + integer(IN) :: latlen + integer(IN) :: lonlen + integer(IN) :: ndims + integer(IN) :: nlatdims + integer(IN) :: nlondims + integer(IN) :: nvars + integer(IN) :: nvarid + integer(IN) :: ndimid + integer(IN) :: strt(nf90_max_var_dims),cnt(nf90_max_var_dims) + integer(IN) :: nlon,nlat + integer(IN), dimension(nf90_max_var_dims) :: dimids + logical :: lfound ! local version of found + character(len=80), allocatable :: vars(:) + character(len=80), allocatable :: latdimnames(:) + character(len=80), allocatable :: londimnames(:) + character(*),parameter :: subname = "(shr_scam_getCloseLatLonNC) " + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ( present(rc) )then + rc = 0 + end if + if ( present(found) )then + lfound = found + else + lfound = .false. + end if + if ( present(rc) )then + rc = 0 ! Initialize return code to something + end if + + !--- Get variable info for search --- + + rcode = nf90_inquire(ncid, nVariables=nvars) + if (rcode /= nf90_noerr) then + call shr_ncread_handleErr( rcode, subname//"ERROR from nf90_inquire" ) + if ( present(rc) )then + rc = rcode + return + end if + endif + + allocate( vars(nvars) ) + do nvarid = 1, nvars + rcode = nf90_inquire_variable(ncid, nvarid, vars(nvarid), ndims=ndims,dimids = dimids) + if (rcode /= nf90_noerr) then + call shr_ncread_handleErr( rcode, subname//"ERROR inquiring about variable "// & + trim(vars(nvarid)) ) + if ( present(rc) )then + rc = rcode + return + end if + endif + !-- If latitude variable --- + if ( is_latlon( vars(nvarid), latitude=.true., varnotdim=.true. ) )then + nlatdims = ndims + allocate( latdimnames(ndims) ) + do ndimid = 1,ndims + rcode = nf90_inquire_dimension(ncid, dimids(ndimid), latdimnames(ndimid), len) + if (rcode /= nf90_noerr) then + call shr_ncread_handleErr( rcode, subname// & + "ERROR: Cant read netcdf latitude variable dimension") + if ( present(rc) )then + rc = rcode + return + end if + endif + !--- is this a latitude dimension --- + if ( is_latlon( latdimnames(ndimid), latitude=.true., varnotdim=.false. ) )then + latlen = len + end if + end do + end if + !-- If longitude variable --- + if ( is_latlon( vars(nvarid), latitude=.false., varnotdim=.true. ) )then + nlondims = ndims + allocate( londimnames(ndims) ) + do ndimid = 1,ndims + rcode = nf90_inquire_dimension(ncid, dimids(ndimid), londimnames(ndimid), len) + call shr_ncread_handleErr( rcode, subname & + //"ERROR: Cant read netcdf longitude variable dimension" ) + if ( rcode /= nf90_noerr .and. present(rc) )then + rc = rcode + return + end if + !--- is this a longitude dimension --- + if ( is_latlon( londimnames(ndimid), latitude=.false., varnotdim=.false. ) )then + lonlen = len + end if + end do + end if + end do + + !--- Look for/extract lat lon coordinate variables from file --- + + nlat=0 + nlon=0 + nvarid=0 + + !--- Loop through all variables until we find lat and lon --- + + do while (nvarid < nvars .and.(nlon.eq.0 .or. nlat.eq.0)) + nvarid=nvarid+1 + + !--- Get latitude --- + + if ( is_latlon( vars(nvarid), latitude=.true., varnotdim=.true. ) )then + + call get_latlonindices( latitude=.true., dimnames=latdimnames, ndims=nlatdims, & + nlen=latlen, strt=strt, cnt=cnt ) + nlat = latlen + allocate(lats(nlat)) + rcode= nf90_get_var(ncid, nvarid ,lats, start = strt, count = cnt) + call shr_ncread_handleErr( rcode, subname & + //"ERROR: Cant read netcdf latitude" ) + if ( rcode /= nf90_noerr .and. present(rc) )then + rc = rcode + return + end if + end if + + !--- Get longitude --- + + if ( is_latlon( vars(nvarid), latitude=.false., varnotdim=.true. ) )then + call get_latlonindices( latitude=.false., ndims=nlondims, dimnames=londimnames, & + nlen=lonlen, strt=strt, cnt=cnt ) + nlon = lonlen + allocate(lons(nlon)) + rcode= nf90_get_var(ncid, nvarid ,lons, start = strt, count = cnt) + call shr_ncread_handleErr( rcode, subname & + //"ERROR: Cant read netcdf longitude" ) + if ( rcode /= nf90_noerr .and. present(rc) )then + rc = rcode + return + end if + end if + end do + if ( present(found) )then + if ( nlat == 0 .or. nlon == 0 ) then + write(s_logunit,*) subname//"WARNING: Cant find appropriate latitude or longitude coordinate variables" + found = .false. + else + call get_close( targetLon, targetLat, nlon, lons, nlat, lats, closelonidx, closelatidx, found ) + if ( found )then + closelon=lons(closelonidx) + closelat=lats(closelatidx) + end if + end if + else + + call get_close( targetLon, targetLat, nlon, lons, nlat, lats, closelonidx, closelatidx ) + closelon=lons(closelonidx) + closelat=lats(closelatidx) + + end if + + if ( allocated(lats) ) deallocate(lats) + if ( allocated(lons) ) deallocate(lons) + if ( allocated(latdimnames) ) deallocate(latdimnames) + if ( allocated(londimnames) ) deallocate(londimnames) + if ( allocated(vars) ) deallocate( vars ) + + return + +end subroutine shr_scam_getCloseLatLonNC + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_scam_getCloseLatLonPIO +! +! !DESCRIPTION: +! routine to search in netcdf file and return lat and lon point/index +! closest to target point using PIO. +! +! !REVISION HISTORY: +! 2010 Nov 01 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_scam_getCloseLatLonPIO(pioid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found, rc ) + use netcdf + use pio + use shr_ncread_mod, only: shr_ncread_handleErr + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(file_desc_t), intent(inout) :: pioid ! pio file ID + real (R8), intent(in) :: targetLat ! find closest latitude to this point + real (R8), intent(in) :: targetLon ! find closest longitude to this point + real (R8), intent(out) :: closeLat ! returned close lat + real (R8), intent(out) :: closeLon ! returned close lon + integer(IN), intent(out) :: closeLatIdx ! index of returned lat point + integer(IN), intent(out) :: closeLonIdx ! index of returned lon point + logical, optional, intent(out) :: found ! if found answer (will abort if found NOT sent and + ! it couldn't find the lat/lon dimensions) + integer, optional, intent(out) :: rc ! Return code + +!EOP + + + !----- local variables ----- + real (R8),allocatable :: lats(:),lons(:) + integer(IN) :: rcode ! netCDF routine return code + integer(IN) :: i + integer(IN) :: len = 0 + integer(IN) :: latlen = 0 + integer(IN) :: lonlen = 0 + integer(IN) :: ndims = 0 + integer(IN) :: nlatdims = 0 + integer(IN) :: nlondims = 0 + integer(IN) :: nvars = 0 + integer(IN) :: nvarid + integer(IN) :: ndimid + integer(IN) :: strt(nf90_max_var_dims),cnt(nf90_max_var_dims) + integer(IN) :: nlon = 0, nlat = 0 + logical :: lfound ! local version of found + integer(IN), dimension(nf90_max_var_dims) :: dimids + character(len=80), allocatable :: vars(:) + character(len=80), allocatable :: latdimnames(:) + character(len=80), allocatable :: londimnames(:) + character(*),parameter :: subname = "(shr_scam_getCloseLatLonPIO) " + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ( present(found) )then + lfound = found + else + lfound = .false. + end if + if ( present(rc) )then + rc = 0 ! Initialize return code to something + end if + !--- Get variable info for search --- + + call pio_seterrorhandling(pioid,PIO_BCAST_ERROR) + rcode = pio_inquire(pioid, nVariables=nvars) + if (rcode /= PIO_noerr) then + call shr_ncread_handleErr( rcode, subname//"ERROR: from PIO_inquire ") + if ( present(rc) )then + rc = rcode + return + end if + endif + + allocate( vars(nvars) ) + do nvarid = 1, nvars + rcode = pio_inquire_variable(pioid, nvarid, vars(nvarid), ndims=ndims,dimids = dimids) + if (rcode /= PIO_noerr) then + write(s_logunit,*) subname//"ERROR inquiring about variable id #", nvarid + call shr_ncread_handleErr( rcode, subname//"ERROR: inquiring about variable" ) + if ( present(rc) )then + rc = rcode + return + end if + endif + !-- If latitude variable --- + if ( is_latlon( vars(nvarid), latitude=.true., varnotdim=.true. ) )then + nlatdims = ndims + allocate( latdimnames(ndims) ) + do ndimid = 1,ndims + rcode = pio_inquire_dimension(pioid, dimids(ndimid), latdimnames(ndimid), len) + if (rcode /= pio_noerr) then + call shr_ncread_handleErr( rcode, subname// & + "ERROR: Cant read netcdf latitude variable dimension") + if ( present(rc) )then + rc = rcode + return + end if + endif + !--- is this a latitude dimension --- + if ( is_latlon( latdimnames(ndimid), latitude=.true., varnotdim=.false. ) )then + latlen = len + end if + end do + end if + !-- If longitude variable --- + if ( is_latlon( vars(nvarid), latitude=.false., varnotdim=.true. ) )then + nlondims = ndims + allocate( londimnames(ndims) ) + do ndimid = 1,ndims + rcode = pio_inquire_dimension(pioid, dimids(ndimid), londimnames(ndimid), len) + if (rcode /= PIO_noerr) then + call shr_ncread_handleErr( rcode, subname// & + "ERROR: Cant read netcdf longitude variable dimension") + if ( present(rc) )then + rc = rcode + return + end if + endif + !--- is this a longitude dimension --- + if ( is_latlon( londimnames(ndimid), latitude=.false., varnotdim=.false. ) )then + lonlen = len + end if + end do + end if + end do + + !--- Look for/extract lat lon coordinate variables from file --- + + nlat=0 + nlon=0 + nvarid=0 + + !--- Loop through all variables until we find lat and lon --- + + do while (nvarid < nvars .and.(nlon.eq.0 .or. nlat.eq.0)) + nvarid=nvarid+1 + + !--- Get latitude --- + + if ( is_latlon( vars(nvarid), latitude=.true., varnotdim=.true. ) )then + + call get_latlonindices( latitude=.true., ndims=nlatdims, dimnames=latdimnames, & + nlen=latlen, strt=strt, cnt=cnt ) + nlat = latlen + allocate(lats(nlat)) + rcode= pio_get_var(pioid, nvarid ,strt(:nlatdims), cnt(:nlatdims), lats) + if (rcode /= PIO_noerr) then + call shr_ncread_handleErr( rcode, subname// & + "ERROR: Cant read netcdf latitude") + if ( present(rc) )then + rc = rcode + return + end if + endif + end if + + !--- Get longitude --- + + if ( is_latlon( vars(nvarid), latitude=.false., varnotdim=.true. ) )then + call get_latlonindices( latitude=.false., ndims=nlondims, dimnames=londimnames, & + nlen=lonlen, strt=strt, cnt=cnt ) + nlon = lonlen + allocate(lons(nlon)) + rcode= pio_get_var(pioid, nvarid ,strt(:nlondims), cnt(:nlondims), lons) + if (rcode /= PIO_noerr) then + call shr_ncread_handleErr( rcode, subname// & + "ERROR: Cant read netcdf longitude") + if ( present(rc) )then + rc = rcode + return + end if + endif + end if + end do + call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR) + + if ( present(found) )then + if ( nlat == 0 .or. nlon == 0 ) then + write(s_logunit,*) subname//"WARNING: Cant find appropriate latitude or longitude coordinate variables" + found = .false. + else + call get_close( targetLon, targetLat, nlon, lons, nlat, lats, closelonidx, closelatidx, found ) + if ( found )then + closelon=lons(closelonidx) + closelat=lats(closelatidx) + end if + end if + else + call get_close( targetLon, targetLat, nlon, lons, nlat, lats, closelonidx, closelatidx ) + closelon=lons(closelonidx) + closelat=lats(closelatidx) + end if + if ( allocated(lats) ) deallocate(lats) + if ( allocated(lons) ) deallocate(lons) + deallocate( vars ) + + return +end subroutine shr_scam_getCloseLatLonPIO + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_scam_getCloseLatLonFile +! +! !DESCRIPTION: +! routine to search in netcdf file and return lat and lon point/index closest to target point +! +! !REVISION HISTORY: +! 2010 Oct 27 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_scam_getCloseLatLonFile(filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found, rc) +! !USES: + use shr_ncread_mod, only: shr_ncread_open, shr_ncread_close + use netcdf + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(len=*),intent(in) :: filename ! Input NetCDF filename + real (R8),intent(in) :: targetLat ! find closest latitude to this point + real (R8),intent(in) :: targetLon ! find closest longitude to this point + real (R8),intent(out) :: closeLat ! returned close lat + real (R8),intent(out) :: closeLon ! returned close lon + integer(IN),intent(out) :: closeLatIdx ! index of returned lat point + integer(IN),intent(out) :: closeLonIdx ! index of returned lon point + logical, optional, intent(out) :: found ! if found answer (will abort if found NOT sent and + ! it couldn't find the lat/lon dimensions) + integer, optional, intent(out) :: rc ! Return code + +!EOP + + + !----- local variables ----- + integer :: ncid ! NetCDF file ID + integer :: rCode ! return code + character(*),parameter :: subname = "(shr_scam_getCloseLatLonFile) " + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + call shr_ncread_open(fileName,ncid,rCode) + if ( rCode /= NF90_NOERR )then + found = .false. + if ( present(rc) ) rc = rCode + return + end if + call shr_scam_getCloseLatLonNC(ncid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rCode) + if ( rCode /= 0 )then + if ( present(rc) ) rc = rCode + return + end if + call shr_ncread_close(ncid,rCode) + if ( rCode /= NF90_NOERR )then + if ( present(rc) ) rc = rCode + end if + +end subroutine shr_scam_getCloseLatLonFile + + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_scam_checkSurface +! +! !DESCRIPTION: +! routine to check grid fraction from the focndomain dataset +! and provide information to correctly flag land, ocean or ice for +! single column mode +! +! !REVISION HISTORY: +! 2007 Aug 29 - J. Truesdale - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_scam_checkSurface(scmlon, scmlat, ocn_compid, ocn_mpicom, & + lnd_present, sno_present, ocn_present, ice_present, & + rof_present, flood_present, rofice_present) + +! !USES: + use shr_dmodel_mod ! shr data model stuff + use mct_mod + use netcdf + use shr_strdata_mod, only : shr_strdata_readnml, shr_strdata_type + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + real(R8), intent(in) :: scmlon,scmlat ! single column lat lon + integer(IN), intent(in) :: ocn_compid ! id for ocean model + integer(IN), intent(in) :: ocn_mpicom ! mpi communicator for ocean + logical, optional, intent(inout) :: lnd_present ! land point + logical, optional, intent(inout) :: sno_present ! land doing sno + logical, optional, intent(inout) :: ice_present ! ice point + logical, optional, intent(inout) :: ocn_present ! ocean point + logical, optional, intent(inout) :: rof_present ! land point with rof + logical, optional, intent(inout) :: flood_present ! rof doing flood + logical, optional, intent(inout) :: rofice_present ! land point with rof + +!EOP + + !----- local variables ----- + type(shr_strdata_type) :: SCAMSDAT + integer(IN) :: rcode ! error code + integer(IN) :: ncid_ocn ! netcdf id for ocn_in + integer(IN) :: fracid ! id for frac variable + integer(IN) :: closeLatIdx ! index of returned lat point + integer(IN) :: closeLonIdx ! index of returned lon point + integer(IN) :: unitn ! io unit + real (R8) :: ocn_frac(1,1) ! ocean fraction + real (R8) :: closeLat ! returned close lat + real (R8) :: closeLon ! returned close lon + character(len=CL) :: nrevsn = ' ' ! full path restart file for branch + character(len=CL) :: rest_pfile = './rpointer.dom' ! restart pointer file + character(len=CL) :: bndtvs ! sst file + character(len=CL) :: focndomain ! ocn domain file + logical :: sstcyc ! flag for sst cycling + logical :: docn_exists ! flag if file exists locally + logical :: ocn_exists ! flag if file exists locally + logical :: exists ! flag if file exists locally + + ! Whether the grid point is over ocn or land (or both). + logical :: ocn_point + logical :: lnd_point + + !----- formats ----- + character(*),parameter :: subname = "(shr_scam_checkSurface) " + character(*),parameter :: F00 = "('(shr_scam_checkSurface) ',8a)" + character(len=CL) :: decomp = '1d' ! restart pointer file + character(len=CL) :: restfilm = 'unset' + character(len=CL) :: restfils = 'unset' + character(len=CL) :: ocn_in = 'unset' + integer(IN) :: nfrac + logical :: force_prognostic_true = .false. + namelist /dom_inparm/ sstcyc, nrevsn, rest_pfile, bndtvs, focndomain + namelist / docn_nml / ocn_in, decomp, force_prognostic_true, & + restfilm, restfils + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + inquire( file='ocn_in', exist=ocn_exists ) + inquire( file='docn_in', exist=docn_exists ) + if (ocn_exists) then + !--- read in the ocn_in namelist to get name for focndomain file + + unitn = shr_file_getUnit() ! get an unused unit number + open( unitn, file='ocn_in', status='old' ) + rcode = 1 + do while ( rcode /= 0 ) + read(unitn, dom_inparm, iostat=rcode) + if (rcode < 0) then + call shr_sys_abort( 'shr_scam_checkSurface encountered end-of-file on namelist read' ) + endif + end do + close( unitn ) + call shr_file_freeUnit(unitn) + + !--- open the netcdf file --- + + inquire(file=trim(focndomain),exist=exists) + if (.not.exists) call shr_sys_abort(subName//"ERROR: file does not exist: "//trim(focndomain)) + rcode = nf90_open(focndomain,nf90_nowrite,ncid_ocn) + if (rCode /= nf90_noerr) call shr_sys_abort(subName//"ERROR opening data file : "//trim(focndomain)) + if (s_loglev > 0) write(s_logunit,F00) 'opened netCDF data file: ',trim(focndomain) + + !--- Extract the fraction for current column --- + + call shr_scam_getCloseLatLon(ncid_ocn,scmlat,scmlon,closelat,closelon,closelatidx,closelonidx) + rcode = nf90_inq_varid(ncid_ocn, 'frac', fracid) + if (rcode /= nf90_noerr) then + call shr_sys_abort(subname//"ERROR getting varid from variable frac in file "//trim(focndomain)) + end if + rcode = nf90_get_var(ncid_ocn,fracid,ocn_frac,start=(/closelonidx,closelatidx/),count=(/1,1/)) + if (rcode /= nf90_noerr) then + call shr_sys_abort(subname//"ERROR getting ocean fraction from "//trim(focndomain)) + end if + + !--- Set the appropriate surface flags based on ocean fraction. + + ocn_point = (ocn_frac(1,1) > 0._r8) + lnd_point = (ocn_frac(1,1) < 1._r8) + else if (docn_exists) then + !--- read in the ocn_in namelist to get name for focndomain file + + unitn = shr_file_getUnit() ! get an unused unit number + open( unitn, file='docn_in', status='old' ) + rcode = 1 + do while ( rcode /= 0 ) + read (unitn,nml=docn_nml,iostat=rcode) + if (rcode < 0) then + call shr_sys_abort( 'shr_scam_checkSurface encountered end-of-file on namelist read' ) + endif + end do + close( unitn ) + call shr_file_freeUnit(unitn) + call shr_strdata_readnml(SCAMSDAT,ocn_in) + call shr_dmodel_readgrid(SCAMSDAT%grid,SCAMSDAT%gsmap,SCAMSDAT%nxg,SCAMSDAT%nyg, & + SCAMSDAT%domainfile, ocn_compid, ocn_mpicom, '1d', readfrac=.true., & + scmmode=.true.,scmlon=scmlon,scmlat=scmlat) + nfrac = mct_aVect_indexRA(SCAMSDAT%grid%data,'frac') + + ocn_point = (SCAMSDAT%grid%data%rAttr(nfrac,1) > 0._r8) + lnd_point = (SCAMSDAT%grid%data%rAttr(nfrac,1) < 1._r8) + call mct_ggrid_clean(SCAMSDAT%grid) + call mct_gsmap_clean(SCAMSDAT%gsmap) + else + ! Exit early if no ocn component + ocn_point = .false. + lnd_point = .true. + end if + + ! If land is on but point is not over land, turn it off. + if (present(lnd_present)) lnd_present = lnd_present .and. lnd_point + if (present(sno_present)) sno_present = sno_present .and. lnd_point + + ! If ocean is on but point is not over ocean, turn it off. + if (present(ocn_present)) ocn_present = ocn_present .and. ocn_point + if (present(ice_present)) ice_present = ice_present .and. ocn_point + + ! Always turn rof off. + if (present(rof_present)) rof_present = .false. + if (present(flood_present)) flood_present = .false. + if (present(rofice_present)) rofice_present = .false. + +end subroutine shr_scam_checkSurface + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: is_latlon +! +! !DESCRIPTION: +! +! Returns true if the given variable name is a valid latitude or longitude +! name. The logical input variable latitude is a flag to indicate if you are +! checking for latitude or longitude variable names. +! +! !REVISION HISTORY: +! 2010 Oct 27 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ +logical function is_latlon( var_name, latitude, varnotdim ) +! !USES: +! !INPUT/OUTPUT PARAMETERS: + implicit none + character(len=*), intent(in) :: var_name ! Input variable name + logical, intent(in) :: latitude ! Flag, true if you want a latitude variable + ! if false check for longitude + logical, intent(in) :: varnotdim ! Flag, true if this is a variable + ! and NOT a dimension +!EOP + + !----- local variables ----- + character(len=3) :: xyvar ! Variable name for 2D x-y coordinate variables + character(len=3) :: Capxyvar ! change xyvar to caps + character(len=11) :: gcvar ! Variable name for gridcell coordinate variables +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + is_latlon = .false. + if ( latitude )then + if ( varnotdim )then + xyvar = "yc" + Capxyvar = "YC" + gcvar = "grid1d_lat" + else + xyvar = "nj" + Capxyvar = "NJ" + gcvar = "gridcell" + end if + if ( trim(var_name) == 'lat' .or. trim(var_name) == 'latixy' .or. & + trim(var_name) == trim(xyvar) .or. trim(var_name) == 'lsmlat' .or. & + trim(var_name) == trim(gcvar) .or. & + trim(var_name) == 'LAT' .or. trim(var_name) == 'LATIXY' .or. & + trim(var_name) == trim(Capxyvar) .or. trim(var_name) == 'LSMLAT' ) then + is_latlon = .true. + else + is_latlon = .false. + end if + else + if ( varnotdim )then + xyvar = "xc" + Capxyvar = "XC" + gcvar = "grid1d_lon" + else + xyvar = "ni" + Capxyvar = "NI" + gcvar = "gridcell" + end if + if ( trim(var_name) == 'lon' .or. trim(var_name) == 'longxy' .or. & + trim(var_name) == trim(xyvar) .or. trim(var_name) == 'lsmlon' .or. & + trim(var_name) == trim(gcvar) .or. & + trim(var_name) == 'LON' .or. trim(var_name) == 'LONGXY' .or. & + trim(var_name) == trim(Capxyvar) .or. trim(var_name) == 'LSMLON' ) then + is_latlon = .true. + else + is_latlon = .false. + end if + end if + return +end function is_latlon + +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: get_latlonindices +! +! !DESCRIPTION: +! Get the start and count indices to retreive latitude or longitude +! +! !REVISION HISTORY: +! 2010 Nov 03 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine get_latlonindices( latitude, ndims, dimnames, nlen, strt, cnt ) +! !USES: +! !INPUT/OUTPUT PARAMETERS: + implicit none + logical, intent(IN) :: latitude ! If this is latitude or not (long) + integer(IN), intent(IN) :: ndims ! Number of dimensions + character(len=*), intent(IN) :: dimnames(ndims) ! Dimension names + integer(IN), intent(IN) :: nlen ! Dimension length + integer(IN), intent(OUT) :: strt(ndims) ! Start along dimension + integer(IN), intent(OUT) :: cnt(ndims) ! Count along dimension +!EOP + + !----- local variables ----- + integer(IN) :: ndimid + logical :: found = .false. + character(*),parameter :: subname = "(shr_scam_getlatlonindices) " +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if ( ndims == 0 )then + call shr_sys_abort( subname//"ERROR: Could NOT find dimension") + end if + if ( nlen == 0 )then + call shr_sys_abort( subname//"ERROR: Could NOT find dimension length") + end if + do ndimid = 1, ndims + !--- is this a lat/longitude dimension --- + if ( is_latlon( dimnames(ndimid), latitude=latitude, varnotdim=.false. ) )then + strt(ndimid) = 1 + cnt(ndimid) = nlen + found = .true. + else + strt(ndimid) = 1 + cnt(ndimid) = 1 + endif + end do + if (.not. found ) then + if ( latitude )then + call shr_sys_abort( subname//"ERROR: Cant find a useable latitude dimension" ) + else + call shr_sys_abort( subname//"ERROR: Cant find a useable longitude dimension") + end if + end if +end subroutine get_latlonindices + +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: get_close +! +! !DESCRIPTION: +! Get the close latitude and longitude indices for latitude/longitude. +! +! !REVISION HISTORY: +! 2010 Nov 03 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine get_close( targetlon, targetlat, nlon, lons, nlat, lats, closelonidx, & + closelatidx, found ) + +! !USES: +! !INPUT/OUTPUT PARAMETERS: + implicit none + real (R8),intent(in) :: targetLon ! find closest longitude to this point + real (R8),intent(in) :: targetLat ! find closest latitude to this point + integer(IN),intent(in) :: nlon ! Number of longitudes + real (R8),intent(in) :: lons(nlon) ! Longitude array + integer(IN),intent(in) :: nlat ! Number of latitudes + real (R8),intent(in) :: lats(nlat) ! Latitude array + integer(IN),intent(out) :: closeLatIdx ! index of returned lat point + integer(IN),intent(out) :: closeLonIdx ! index of returned lon point + logical, optional, intent(out):: found ! if found answer (will abort if found NOT sent and + ! it couldn't find the lat/lon dimensions) +!EOP + + !----- local variables ----- + real (R8),allocatable :: poslons(:) + real (R8) :: postargetlon + character(*),parameter :: subname = "(shr_scam_getclose) " +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + if ( present(found) )then + found = .true. + end if + + !--- Did we get find valid lat and lon coordinate variables --- + + if (nlon == 0) then + write(s_logunit,*) subname//"ERROR: Coudnt find longitude coordinate" + if ( present(found) )then + found = .false. + return + else + call shr_sys_abort( subname//"ERROR: Couldnt find a longitude coordinate variable") + end if + end if + if (nlat == 0) then + write(s_logunit,*) subname//"ERROR: Coudnt find latitude coordinate" + if ( present(found) )then + found = .false. + return + else + call shr_sys_abort( subname//"ERROR: Couldnt find a latitude coordinate variable") + end if + end if + !--- Convert target latitude to within 0-360 --- + postargetlon=mod(targetlon+360._r8,360._r8) + + !--- Make sure target latitude within globe --- + if ( targetlat < -90.0_r8 .or. targetlat > 90.0_r8 )then + write(s_logunit,*) subname//"ERROR: target latitude out of range = ", targetlat + if ( present(found) )then + found = .false. + return + else + call shr_sys_abort( subname//"ERROR: target latitude out of reasonable range") + end if + end if + + !--- convert lons array and targetlon to 0,360 --- + + allocate(poslons(nlon)) + poslons=mod(lons+360._r8,360._r8) + + !--- find index of value closest to 0 and set returned values --- + + closelonidx=(MINLOC(abs(poslons-postargetlon),dim=1)) + closelatidx=(MINLOC(abs(lats-targetlat),dim=1)) + + !--- if it gets here we need to clean up after ourselves --- + + deallocate(poslons) + return +end subroutine get_close + +!=============================================================================== + +end module shr_scam_mod + diff --git a/share/csm_share/shr/shr_spfn_mod.F90 b/share/csm_share/shr/shr_spfn_mod.F90 new file mode 100644 index 000000000000..1a123ea5665a --- /dev/null +++ b/share/csm_share/shr/shr_spfn_mod.F90 @@ -0,0 +1,1046 @@ + +! Define flags for compilers supporting Fortran 2008 intrinsics +! HAVE_GAMMA_INTRINSICS: gamma and log_gamma +! HAVE_ERF_INTRINSICS: erf, erfc, and erfc_scaled +! erfc_scaled(x) = (exp(x**2)*erfc(x)) + +! Use this flag for compilers that don't have real intrinsics, but link in +! a library for you. +! HAVE_ERF_EXTERNALS: erf and erfc + +! These compilers have the intrinsics. +! Intel also has them (and Cray), but as of mid-2015, our implementation is +! actually faster, in part because they do not properly vectorize, so we +! pretend that the compiler version doesn't exist. +#if defined CPRIBM || defined __GFORTRAN__ +#define HAVE_GAMMA_INTRINSICS +#define HAVE_ERF_INTRINSICS +#endif + +! PGI has external erf/derf and erfc/derfc, and will link them for you, but +! it does not consider them "intrinsics" right now. +#if defined CPRPGI +#define HAVE_ERF_EXTERNALS +#endif + +! As of 5.3.1, NAG does not have any of these. + +module shr_spfn_mod +! Module for common mathematical functions + +! This #ifdef is to allow the module to be compiled with no dependencies, +! even on shr_kind_mod. +#ifndef NO_CSM_SHARE +use shr_kind_mod, only: & + r4 => shr_kind_r4, & + r8 => shr_kind_r8 +use shr_const_mod, only: & + pi => shr_const_pi +#endif + +implicit none +private +save + +#ifdef NO_CSM_SHARE +integer, parameter :: r4 = selected_real_kind(6) ! 4 byte real +integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real +real(r8), parameter :: pi = 3.1415926535897932384626434E0_r8 +#endif + +! Error functions +public :: shr_spfn_erf +public :: shr_spfn_erfc +public :: shr_spfn_erfc_scaled + +interface shr_spfn_erf + module procedure shr_spfn_erf_r4 + module procedure shr_spfn_erf_r8 +end interface + +interface shr_spfn_erfc + module procedure shr_spfn_erfc_r4 + module procedure shr_spfn_erfc_r8 +end interface + +interface shr_spfn_erfc_scaled + module procedure shr_spfn_erfc_scaled_r4 + module procedure shr_spfn_erfc_scaled_r8 +end interface + +! Gamma functions +! Note that we lack an implementation of log_gamma, but we do have an +! implementation of the upper incomplete gamma function, which is not in +! Fortran 2008. + +! Note also that this gamma function is only for double precision. We +! haven't needed an r4 version yet. + +public :: shr_spfn_gamma +public :: shr_spfn_igamma + +interface shr_spfn_gamma + module procedure shr_spfn_gamma_r8 +end interface + +! Mathematical constants +! sqrt(pi) +real(r8), parameter :: sqrtpi = 1.77245385090551602729_r8 + +! Define machine-specific constants needed in this module. +! These were used by the original gamma and calerf functions to guarantee +! safety against overflow, and precision, on many different machines. + +! By defining the constants in this way, we assume that 1/xmin is +! representable (i.e. does not overflow the real type). This assumption was +! not in the original code, but is valid for IEEE single and double +! precision. + +! Double precision +!--------------------------------------------------------------------- +! Machine epsilon +real(r8), parameter :: epsr8 = epsilon(1._r8) +! "Huge" value is returned when actual value would be infinite. +real(r8), parameter :: xinfr8 = huge(1._r8) +! Smallest normal value. +real(r8), parameter :: xminr8 = tiny(1._r8) +! Largest number that, when added to 1., yields 1. +real(r8), parameter :: xsmallr8 = epsr8/2._r8 +! Largest argument for which erfcx > 0. +real(r8), parameter :: xmaxr8 = 1._r8/(sqrtpi*xminr8) + +! Single precision +!--------------------------------------------------------------------- +! Machine epsilon +real(r4), parameter :: epsr4 = epsilon(1._r4) +! "Huge" value is returned when actual value would be infinite. +real(r4), parameter :: xinfr4 = huge(1._r4) +! Smallest normal value. +real(r4), parameter :: xminr4 = tiny(1._r4) +! Largest number that, when added to 1., yields 1. +real(r4), parameter :: xsmallr4 = epsr4/2._r4 +! Largest argument for which erfcx > 0. +real(r4), parameter :: xmaxr4 = 1._r4/(real(sqrtpi,r4)*xminr4) + + +! For gamma/igamma +! Approximate value of largest acceptable argument to gamma, +! for IEEE double-precision. +real(r8), parameter :: xbig_gamma = 171.624_r8 + +contains + +! Wrapper functions for erf +function shr_spfn_erf_r4(x) result(res) + real(r4), intent(in) :: x + real(r4) :: res + +#ifdef HAVE_ERF_EXTERNALS + ! If erf is provided as an external, provide + ! explicit interface here. + interface + function erf(x) + import :: r4 + real(r4) :: x, erf + end function erf + end interface +#endif + +#ifdef HAVE_ERF_INTRINSICS + + ! Call intrinsic erf. + intrinsic erf + res = erf(x) +#else + +#ifdef HAVE_ERF_EXTERNALS + ! Call compiler-provided external erf. + res = erf(x) +#else + ! No compiler-provided erf, so call local version. + call calerf_r4(x, res, 0) +#endif + +#endif + +end function shr_spfn_erf_r4 + +function shr_spfn_erf_r8(x) result(res) + real(r8), intent(in) :: x + real(r8) :: res + +#ifdef HAVE_ERF_EXTERNALS + ! If erf is provided as an external, provide + ! explicit interface here. + interface + function derf(x) + import :: r8 + real(r8) :: x, derf + end function derf + end interface +#endif + +#ifdef HAVE_ERF_INTRINSICS + ! Call intrinsic erf. + intrinsic erf + res = erf(x) +#else + +#ifdef HAVE_ERF_EXTERNALS + ! Call compiler-provided external erf. + res = derf(x) +#else + ! No compiler-provided erf, so call local version. + call calerf_r8(x, res, 0) +#endif + +#endif + +end function shr_spfn_erf_r8 + +! Wrapper functions for erfc +function shr_spfn_erfc_r4(x) result(res) + real(r4), intent(in) :: x + real(r4) :: res + +#ifdef HAVE_ERF_EXTERNALS + ! If erfc is provided as an external, provide + ! explicit interface here. + interface + function erfc(x) + import :: r4 + real(r4) :: x, erfc + end function erfc + end interface +#endif + +#ifdef HAVE_ERF_INTRINSICS + ! Call intrinsic erfc. + intrinsic erfc + res = erfc(x) +#else + +#ifdef HAVE_ERF_EXTERNALS + ! Call compiler-provided external erfc. + res = erfc(x) +#else + ! No compiler-provided erfc, so call local version. + call calerf_r4(x, res, 1) +#endif + +#endif + +end function shr_spfn_erfc_r4 + +function shr_spfn_erfc_r8(x) result(res) + real(r8), intent(in) :: x + real(r8) :: res + +#ifdef HAVE_ERF_EXTERNALS + ! If erfc is provided as an external, provide + ! explicit interface here. + interface + function derfc(x) + import :: r8 + real(r8) :: x, derfc + end function derfc + end interface +#endif + +#ifdef HAVE_ERF_INTRINSICS + ! Call intrinsic erfc. + intrinsic erfc + res = erfc(x) +#else + +#ifdef HAVE_ERF_EXTERNALS + ! Call compiler-provided external erfc. + res = derfc(x) +#else + ! No compiler-provided erfc, so call local version. + call calerf_r8(x, res, 1) +#endif + +#endif + +end function shr_spfn_erfc_r8 + +! Wrapper functions for erfc_scaled +function shr_spfn_erfc_scaled_r4(x) result(res) + real(r4), intent(in) :: x + real(r4) :: res + +#if defined HAVE_ERF_INTRINSICS + ! Call intrinsic erfc_scaled. + intrinsic erfc_scaled + res = erfc_scaled(x) +#else + ! No intrinsic. + call calerf_r4(x, res, 2) +#endif + +end function shr_spfn_erfc_scaled_r4 + +function shr_spfn_erfc_scaled_r8(x) result(res) + real(r8), intent(in) :: x + real(r8) :: res + +#if defined HAVE_ERF_INTRINSICS + ! Call intrinsic erfc_scaled. + intrinsic erfc_scaled + res = erfc_scaled(x) +#else + ! No intrinsic. + call calerf_r8(x, res, 2) +#endif + +end function shr_spfn_erfc_scaled_r8 + +elemental function shr_spfn_gamma_r8(x) result(res) + real(r8), intent(in) :: x + real(r8) :: res + +#if defined HAVE_GAMMA_INTRINSICS + ! Call intrinsic gamma. + intrinsic gamma + res = gamma(x) +#else + ! No intrinsic + res = shr_spfn_gamma_nonintrinsic_r8(x) +#endif + +end function shr_spfn_gamma_r8 + +!------------------------------------------------------------------ +! +! 6 December 2006 -- B. Eaton +! The following comments are from the original version of CALERF. +! The only changes in implementing this module are that the function +! names previously used for the single precision versions have been +! adopted for the new generic interfaces. To support these interfaces +! there is now both a single precision version (calerf_r4) and a +! double precision version (calerf_r8) of CALERF below. These versions +! are hardcoded to use IEEE arithmetic. +! +!------------------------------------------------------------------ +! +! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) +! for a real argument x. It contains three FUNCTION type +! subprograms: ERF, ERFC, and ERFCX (or ERF_R8, ERFC_R8, and ERFCX_R8), +! and one SUBROUTINE type subprogram, CALERF. The calling +! statements for the primary entries are: +! +! Y=ERF(X) (or Y=ERF_R8(X)), +! +! Y=ERFC(X) (or Y=ERFC_R8(X)), +! and +! Y=ERFCX(X) (or Y=ERFCX_R8(X)). +! +! The routine CALERF is intended for internal packet use only, +! all computations within the packet being concentrated in this +! routine. The function subprograms invoke CALERF with the +! statement +! +! CALL CALERF(ARG,RESULT,JINT) +! +! where the parameter usage is as follows +! +! Function Parameters for CALERF +! call ARG Result JINT +! +! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 +! ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 +! ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 +! +! The main computation evaluates near-minimax approximations +! from "Rational Chebyshev approximations for the error function" +! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This +! transportable program uses rational functions that theoretically +! approximate erf(x) and erfc(x) to at least 18 significant +! decimal digits. The accuracy achieved depends on the arithmetic +! system, the compiler, the intrinsic functions, and proper +! selection of the machine-dependent constants. +! +!******************************************************************* +!******************************************************************* +! +! Explanation of machine-dependent constants +! +! XMIN = the smallest positive floating-point number. +! XINF = the largest positive finite floating-point number. +! XNEG = the largest negative argument acceptable to ERFCX; +! the negative of the solution to the equation +! 2*exp(x*x) = XINF. +! XSMALL = argument below which erf(x) may be represented by +! 2*x/sqrt(pi) and above which x*x will not underflow. +! A conservative value is the largest machine number X +! such that 1.0 + X = 1.0 to machine precision. +! XBIG = largest argument acceptable to ERFC; solution to +! the equation: W(x) * (1-0.5/x**2) = XMIN, where +! W(x) = exp(-x*x)/[x*sqrt(pi)]. +! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to +! machine precision. A conservative value is +! 1/[2*sqrt(XSMALL)] +! XMAX = largest acceptable argument to ERFCX; the minimum +! of XINF and 1/[sqrt(pi)*XMIN]. +! +! Approximate values for some important machines are: +! +! XMIN XINF XNEG XSMALL +! +! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 +! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 +! IEEE (IBM/XT, +! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 +! IEEE (IBM/XT, +! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 +! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 +! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 +! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 +! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 +! +! +! XBIG XHUGE XMAX +! +! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 +! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 +! IEEE (IBM/XT, +! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 +! IEEE (IBM/XT, +! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 +! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 +! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 +! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 +! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 +! +!******************************************************************* +!******************************************************************* +! +! Error returns +! +! The program returns ERFC = 0 for ARG .GE. XBIG; +! +! ERFCX = XINF for ARG .LT. XNEG; +! and +! ERFCX = 0 for ARG .GE. XMAX. +! +! +! Intrinsic functions required are: +! +! ABS, AINT, EXP +! +! +! Author: W. J. Cody +! Mathematics and Computer Science Division +! Argonne National Laboratory +! Argonne, IL 60439 +! +! Latest modification: March 19, 1990 +! +!------------------------------------------------------------------ + +SUBROUTINE CALERF_r8(ARG, RESULT, JINT) + + !------------------------------------------------------------------ + ! This version uses 8-byte reals + !------------------------------------------------------------------ + integer, parameter :: rk = r8 + + ! arguments + real(rk), intent(in) :: arg + integer, intent(in) :: jint + real(rk), intent(out) :: result + + ! local variables + INTEGER :: I + + real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL + + !------------------------------------------------------------------ + ! Mathematical constants + !------------------------------------------------------------------ + real(rk), parameter :: ZERO = 0.0E0_rk + real(rk), parameter :: FOUR = 4.0E0_rk + real(rk), parameter :: ONE = 1.0E0_rk + real(rk), parameter :: HALF = 0.5E0_rk + real(rk), parameter :: TWO = 2.0E0_rk + ! 1/sqrt(pi) + real(rk), parameter :: SQRPI = 5.6418958354775628695E-1_rk + real(rk), parameter :: THRESH = 0.46875E0_rk + real(rk), parameter :: SIXTEN = 16.0E0_rk + + !------------------------------------------------------------------ + ! Machine-dependent constants: IEEE double precision values + !------------------------------------------------------------------ + real(rk), parameter :: XNEG = -26.628E0_r8 + real(rk), parameter :: XBIG = 26.543E0_r8 + real(rk), parameter :: XHUGE = 6.71E7_r8 + + !------------------------------------------------------------------ + ! Coefficients for approximation to erf in first interval + !------------------------------------------------------------------ + real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, & + 3.77485237685302021E02_rk, 3.20937758913846947E03_rk, & + 1.85777706184603153E-1_rk /) + real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, & + 1.28261652607737228E03_rk, 2.84423683343917062E03_rk /) + + !------------------------------------------------------------------ + ! Coefficients for approximation to erfc in second interval + !------------------------------------------------------------------ + real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, & + 6.61191906371416295E01_rk, 2.98635138197400131E02_rk, & + 8.81952221241769090E02_rk, 1.71204761263407058E03_rk, & + 2.05107837782607147E03_rk, 1.23033935479799725E03_rk, & + 2.15311535474403846E-8_rk /) + real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, & + 5.37181101862009858E02_rk, 1.62138957456669019E03_rk, & + 3.29079923573345963E03_rk, 4.36261909014324716E03_rk, & + 3.43936767414372164E03_rk, 1.23033935480374942E03_rk /) + + !------------------------------------------------------------------ + ! Coefficients for approximation to erfc in third interval + !------------------------------------------------------------------ + real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, & + 1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, & + 6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /) + real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, & + 5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, & + 2.33520497626869185E-3_rk /) + + !------------------------------------------------------------------ + X = ARG + Y = ABS(X) + IF (Y .LE. THRESH) THEN + !------------------------------------------------------------------ + ! Evaluate erf for |X| <= 0.46875 + !------------------------------------------------------------------ + YSQ = ZERO + IF (Y .GT. XSMALLR8) YSQ = Y * Y + XNUM = A(5)*YSQ + XDEN = YSQ + DO I = 1, 3 + XNUM = (XNUM + A(I)) * YSQ + XDEN = (XDEN + B(I)) * YSQ + end do + RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) + IF (JINT .NE. 0) RESULT = ONE - RESULT + IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT + GO TO 80 + ELSE IF (Y .LE. FOUR) THEN + !------------------------------------------------------------------ + ! Evaluate erfc for 0.46875 <= |X| <= 4.0 + !------------------------------------------------------------------ + XNUM = C(9)*Y + XDEN = Y + DO I = 1, 7 + XNUM = (XNUM + C(I)) * Y + XDEN = (XDEN + D(I)) * Y + end do + RESULT = (XNUM + C(8)) / (XDEN + D(8)) + IF (JINT .NE. 2) THEN + YSQ = AINT(Y*SIXTEN)/SIXTEN + DEL = (Y-YSQ)*(Y+YSQ) + RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT + END IF + ELSE + !------------------------------------------------------------------ + ! Evaluate erfc for |X| > 4.0 + !------------------------------------------------------------------ + RESULT = ZERO + IF (Y .GE. XBIG) THEN + IF ((JINT .NE. 2) .OR. (Y .GE. XMAXR8)) GO TO 30 + IF (Y .GE. XHUGE) THEN + RESULT = SQRPI / Y + GO TO 30 + END IF + END IF + YSQ = ONE / (Y * Y) + XNUM = P(6)*YSQ + XDEN = YSQ + DO I = 1, 4 + XNUM = (XNUM + P(I)) * YSQ + XDEN = (XDEN + Q(I)) * YSQ + end do + RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) + RESULT = (SQRPI - RESULT) / Y + IF (JINT .NE. 2) THEN + YSQ = AINT(Y*SIXTEN)/SIXTEN + DEL = (Y-YSQ)*(Y+YSQ) + RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT + END IF + END IF +30 continue + !------------------------------------------------------------------ + ! Fix up for negative argument, erf, etc. + !------------------------------------------------------------------ + IF (JINT .EQ. 0) THEN + RESULT = (HALF - RESULT) + HALF + IF (X .LT. ZERO) RESULT = -RESULT + ELSE IF (JINT .EQ. 1) THEN + IF (X .LT. ZERO) RESULT = TWO - RESULT + ELSE + IF (X .LT. ZERO) THEN + IF (X .LT. XNEG) THEN + RESULT = XINFR8 + ELSE + YSQ = AINT(X*SIXTEN)/SIXTEN + DEL = (X-YSQ)*(X+YSQ) + Y = EXP(YSQ*YSQ) * EXP(DEL) + RESULT = (Y+Y) - RESULT + END IF + END IF + END IF +80 continue +end SUBROUTINE CALERF_r8 + +!------------------------------------------------------------------------------------------ + +SUBROUTINE CALERF_r4(ARG, RESULT, JINT) + + !------------------------------------------------------------------ + ! This version uses 4-byte reals + !------------------------------------------------------------------ + integer, parameter :: rk = r4 + + ! arguments + real(rk), intent(in) :: arg + integer, intent(in) :: jint + real(rk), intent(out) :: result + + ! local variables + INTEGER :: I + + real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL + + !------------------------------------------------------------------ + ! Mathematical constants + !------------------------------------------------------------------ + real(rk), parameter :: ZERO = 0.0E0_rk + real(rk), parameter :: FOUR = 4.0E0_rk + real(rk), parameter :: ONE = 1.0E0_rk + real(rk), parameter :: HALF = 0.5E0_rk + real(rk), parameter :: TWO = 2.0E0_rk + ! 1/sqrt(pi) + real(rk), parameter :: SQRPI = 5.6418958354775628695E-1_rk + real(rk), parameter :: THRESH = 0.46875E0_rk + real(rk), parameter :: SIXTEN = 16.0E0_rk + + !------------------------------------------------------------------ + ! Machine-dependent constants: IEEE single precision values + !------------------------------------------------------------------ + real(rk), parameter :: XNEG = -9.382E0_r4 + real(rk), parameter :: XBIG = 9.194E0_r4 + real(rk), parameter :: XHUGE = 2.90E3_r4 + + !------------------------------------------------------------------ + ! Coefficients for approximation to erf in first interval + !------------------------------------------------------------------ + real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, & + 3.77485237685302021E02_rk, 3.20937758913846947E03_rk, & + 1.85777706184603153E-1_rk /) + real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, & + 1.28261652607737228E03_rk, 2.84423683343917062E03_rk /) + + !------------------------------------------------------------------ + ! Coefficients for approximation to erfc in second interval + !------------------------------------------------------------------ + real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, & + 6.61191906371416295E01_rk, 2.98635138197400131E02_rk, & + 8.81952221241769090E02_rk, 1.71204761263407058E03_rk, & + 2.05107837782607147E03_rk, 1.23033935479799725E03_rk, & + 2.15311535474403846E-8_rk /) + real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, & + 5.37181101862009858E02_rk, 1.62138957456669019E03_rk, & + 3.29079923573345963E03_rk, 4.36261909014324716E03_rk, & + 3.43936767414372164E03_rk, 1.23033935480374942E03_rk /) + + !------------------------------------------------------------------ + ! Coefficients for approximation to erfc in third interval + !------------------------------------------------------------------ + real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, & + 1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, & + 6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /) + real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, & + 5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, & + 2.33520497626869185E-3_rk /) + + !------------------------------------------------------------------ + X = ARG + Y = ABS(X) + IF (Y .LE. THRESH) THEN + !------------------------------------------------------------------ + ! Evaluate erf for |X| <= 0.46875 + !------------------------------------------------------------------ + YSQ = ZERO + IF (Y .GT. XSMALLR4) YSQ = Y * Y + XNUM = A(5)*YSQ + XDEN = YSQ + DO I = 1, 3 + XNUM = (XNUM + A(I)) * YSQ + XDEN = (XDEN + B(I)) * YSQ + end do + RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) + IF (JINT .NE. 0) RESULT = ONE - RESULT + IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT + GO TO 80 + ELSE IF (Y .LE. FOUR) THEN + !------------------------------------------------------------------ + ! Evaluate erfc for 0.46875 <= |X| <= 4.0 + !------------------------------------------------------------------ + XNUM = C(9)*Y + XDEN = Y + DO I = 1, 7 + XNUM = (XNUM + C(I)) * Y + XDEN = (XDEN + D(I)) * Y + end do + RESULT = (XNUM + C(8)) / (XDEN + D(8)) + IF (JINT .NE. 2) THEN + YSQ = AINT(Y*SIXTEN)/SIXTEN + DEL = (Y-YSQ)*(Y+YSQ) + RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT + END IF + ELSE + !------------------------------------------------------------------ + ! Evaluate erfc for |X| > 4.0 + !------------------------------------------------------------------ + RESULT = ZERO + IF (Y .GE. XBIG) THEN + IF ((JINT .NE. 2) .OR. (Y .GE. XMAXR4)) GO TO 30 + IF (Y .GE. XHUGE) THEN + RESULT = SQRPI / Y + GO TO 30 + END IF + END IF + YSQ = ONE / (Y * Y) + XNUM = P(6)*YSQ + XDEN = YSQ + DO I = 1, 4 + XNUM = (XNUM + P(I)) * YSQ + XDEN = (XDEN + Q(I)) * YSQ + end do + RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) + RESULT = (SQRPI - RESULT) / Y + IF (JINT .NE. 2) THEN + YSQ = AINT(Y*SIXTEN)/SIXTEN + DEL = (Y-YSQ)*(Y+YSQ) + RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT + END IF + END IF +30 continue + !------------------------------------------------------------------ + ! Fix up for negative argument, erf, etc. + !------------------------------------------------------------------ + IF (JINT .EQ. 0) THEN + RESULT = (HALF - RESULT) + HALF + IF (X .LT. ZERO) RESULT = -RESULT + ELSE IF (JINT .EQ. 1) THEN + IF (X .LT. ZERO) RESULT = TWO - RESULT + ELSE + IF (X .LT. ZERO) THEN + IF (X .LT. XNEG) THEN + RESULT = XINFR4 + ELSE + YSQ = AINT(X*SIXTEN)/SIXTEN + DEL = (X-YSQ)*(X+YSQ) + Y = EXP(YSQ*YSQ) * EXP(DEL) + RESULT = (Y+Y) - RESULT + END IF + END IF + END IF +80 continue +end SUBROUTINE CALERF_r4 + +!------------------------------------------------------------------------------------------ + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +pure function shr_spfn_gamma_nonintrinsic_r8(X) result(gamma) + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! +! 7 Feb 2013 -- S. Santos +! The following comments are from the original version. Changes have +! been made to update syntax and allow inclusion into this module. +! +!---------------------------------------------------------------------- +! +! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. +! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. +! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA +! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS +! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. +! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. +! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE +! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE +! MACHINE-DEPENDENT CONSTANTS. +! +! +!******************************************************************* +!******************************************************************* +! +! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS +! +! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION +! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS +! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE +! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION +! GAMMA(XBIG) = BETA**MAXEXP +! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; +! APPROXIMATELY BETA**MAXEXP +! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT +! 1.0+EPS .GT. 1.0 +! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT +! 1/XMININ IS MACHINE REPRESENTABLE +! +! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: +! +! BETA MAXEXP XBIG +! +! CRAY-1 (S.P.) 2 8191 966.961 +! CYBER 180/855 +! UNDER NOS (S.P.) 2 1070 177.803 +! IEEE (IBM/XT, +! SUN, ETC.) (S.P.) 2 128 35.040 +! IEEE (IBM/XT, +! SUN, ETC.) (D.P.) 2 1024 171.624 +! IBM 3033 (D.P.) 16 63 57.574 +! VAX D-FORMAT (D.P.) 2 127 34.844 +! VAX G-FORMAT (D.P.) 2 1023 171.489 +! +! XINF EPS XMININ +! +! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 +! CYBER 180/855 +! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 +! IEEE (IBM/XT, +! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 +! IEEE (IBM/XT, +! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 +! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 +! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 +! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 +! +!******************************************************************* +!******************************************************************* +! +! ERROR RETURNS +! +! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR +! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED +! TO BE FREE OF UNDERFLOW AND OVERFLOW. +! +! +! INTRINSIC FUNCTIONS REQUIRED ARE: +! +! INT, DBLE, EXP, LOG, REAL, SIN +! +! +! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL +! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, +! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON +! (ED.), SPRINGER VERLAG, BERLIN, 1976. +! +! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND +! SONS, NEW YORK, 1968. +! +! LATEST MODIFICATION: OCTOBER 12, 1989 +! +! AUTHORS: W. J. CODY AND L. STOLTZ +! APPLIED MATHEMATICS DIVISION +! ARGONNE NATIONAL LABORATORY +! ARGONNE, IL 60439 +! +!---------------------------------------------------------------------- + + real(r8), intent(in) :: x + real(r8) :: gamma + real(r8) :: fact, res, sum, xden, xnum, y, y1, ysq, z + + integer :: i, n + logical :: negative_odd + + ! log(2*pi)/2 + real(r8), parameter :: logsqrt2pi = 0.9189385332046727417803297E0_r8 + +!---------------------------------------------------------------------- +! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX +! APPROXIMATION OVER (1,2). +!---------------------------------------------------------------------- + real(r8), parameter :: P(8) = & + (/-1.71618513886549492533811E+0_r8, 2.47656508055759199108314E+1_r8, & + -3.79804256470945635097577E+2_r8, 6.29331155312818442661052E+2_r8, & + 8.66966202790413211295064E+2_r8,-3.14512729688483675254357E+4_r8, & + -3.61444134186911729807069E+4_r8, 6.64561438202405440627855E+4_r8 /) + real(r8), parameter :: Q(8) = & + (/-3.08402300119738975254353E+1_r8, 3.15350626979604161529144E+2_r8, & + -1.01515636749021914166146E+3_r8,-3.10777167157231109440444E+3_r8, & + 2.25381184209801510330112E+4_r8, 4.75584627752788110767815E+3_r8, & + -1.34659959864969306392456E+5_r8,-1.15132259675553483497211E+5_r8 /) +!---------------------------------------------------------------------- +! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). +!---------------------------------------------------------------------- + real(r8), parameter :: C(7) = & + (/-1.910444077728E-03_r8, 8.4171387781295E-04_r8, & + -5.952379913043012E-04_r8, 7.93650793500350248E-04_r8, & + -2.777777777777681622553E-03_r8, 8.333333333333333331554247E-02_r8, & + 5.7083835261E-03_r8 /) + + negative_odd = .false. + fact = 1._r8 + n = 0 + y = x + if (y <= 0._r8) then +!---------------------------------------------------------------------- +! ARGUMENT IS NEGATIVE +!---------------------------------------------------------------------- + y = -x + y1 = aint(y) + res = y - y1 + if (res /= 0._r8) then + negative_odd = (y1 /= aint(y1*0.5_r8)*2._r8) + fact = -pi/sin(pi*res) + y = y + 1._r8 + else + gamma = xinfr8 + return + end if + end if +!---------------------------------------------------------------------- +! ARGUMENT IS POSITIVE +!---------------------------------------------------------------------- + if (y < epsr8) then +!---------------------------------------------------------------------- +! ARGUMENT .LT. EPS +!---------------------------------------------------------------------- + if (y >= xminr8) then + res = 1._r8/y + else + gamma = xinfr8 + return + end if + elseif (y < 12._r8) then + y1 = y + if (y < 1._r8) then +!---------------------------------------------------------------------- +! 0.0 .LT. ARGUMENT .LT. 1.0 +!---------------------------------------------------------------------- + z = y + y = y + 1._r8 + else +!---------------------------------------------------------------------- +! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY +!---------------------------------------------------------------------- + n = int(y) - 1 + y = y - real(n, r8) + z = y - 1._r8 + end if +!---------------------------------------------------------------------- +! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 +!---------------------------------------------------------------------- + xnum = 0._r8 + xden = 1._r8 + do i=1,8 + xnum = (xnum+P(i))*z + xden = xden*z + Q(i) + end do + res = xnum/xden + 1._r8 + if (y1 < y) then +!---------------------------------------------------------------------- +! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 +!---------------------------------------------------------------------- + res = res/y1 + elseif (y1 > y) then +!---------------------------------------------------------------------- +! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 +!---------------------------------------------------------------------- + do i = 1,n + res = res*y + y = y + 1._r8 + end do + end if + else +!---------------------------------------------------------------------- +! EVALUATE FOR ARGUMENT .GE. 12.0, +!---------------------------------------------------------------------- + if (y <= xbig_gamma) then + ysq = y*y + sum = C(7) + do i=1,6 + sum = sum/ysq + C(i) + end do + sum = sum/y - y + logsqrt2pi + sum = sum + (y-0.5_r8)*log(y) + res = exp(sum) + else + gamma = xinfr8 + return + end if + end if +!---------------------------------------------------------------------- +! FINAL ADJUSTMENTS AND RETURN +!---------------------------------------------------------------------- + if (negative_odd) res = -res + if (fact /= 1._r8) res = fact/res + gamma = res +! ---------- LAST LINE OF GAMMA ---------- +end function shr_spfn_gamma_nonintrinsic_r8 + +!! Incomplete Gamma function +!! +!! @author Tianyi Fan +!! @version August-2010 +real(r8) elemental function shr_spfn_igamma(a, x) + ! Upper incomplete gamma function. + ! Modified for inclusion in this module and made + ! pure elemental, September 2012 + + real(r8), intent(in) :: a + real(r8), intent(in) :: x + + ! local variable + real(r8) :: xam, gin, s, r, t0 + integer :: k + + + if (x == 0.0_r8) then + shr_spfn_igamma = shr_spfn_gamma(a) + return + end if + + xam = -x + a * log(x) + + if ((xam > 700.0_r8) .or. (a > xbig_gamma)) then + ! Out of bounds + ! Return "huge" value. + shr_spfn_igamma = xinfr8 + return + + else if (x <= (1.0_r8 + a)) then + s = 1.0_r8 / a + r = s + + do k = 1,60 + r = r * x / (a+k) + s = s + r + + if (abs(r/s) < 1.0e-15_r8) exit + end do + + gin = exp(xam) * s + shr_spfn_igamma = shr_spfn_gamma(a) - gin + + else + t0 = 0.0_r8 + + do k = 60,1,-1 + t0 = (k - a) / (1.0_r8 + k / (x + t0)) + end do + + shr_spfn_igamma = exp(xam) / (x + t0) + endif + +end function shr_spfn_igamma + + +end module shr_spfn_mod diff --git a/share/csm_share/shr/shr_strconvert_mod.F90 b/share/csm_share/shr/shr_strconvert_mod.F90 new file mode 100644 index 000000000000..da8aca24436b --- /dev/null +++ b/share/csm_share/shr/shr_strconvert_mod.F90 @@ -0,0 +1,166 @@ +module shr_strconvert_mod + +! This module defines toString, a generic function for creating character type +! representations of data, as implemented for the most commonly used intrinsic +! types: +! +! - 4 and 8 byte integer +! - 4 and 8 byte real +! - logical +! +! No toString implementation is provided for character input, but this may be +! added if some use case arises. +! +! Currently, only scalar inputs are supported. The return type of this function +! is character with deferred (allocatable) length. +! +! The functions for integers and reals allow an optional format_string argument, +! which can be used to control the padding and precision of output as with any +! write statement. However, the implementations internally must use a +! preallocated buffer, so a format_string that significantly increases the size +! of the output may cause a run-time error or undefined behavior in the program. +! +! Other modules may want to provide extensions of toString for their own derived +! types. In this case there are two guidelines to observe: +! +! - It is preferable to have only one mandatory argument, which is the object to +! produce a string from. There may be other formatting options, but the +! implementation should do something sensible without these. +! +! - Since the main purpose of toString is to provide a human-readable +! representation of a type, especially for documentation or debugging +! purposes, refrain from printing large array components in their entirety +! (instead consider printing only the shape, or statistics such as +! min/mean/max for arrays of numbers). + +use shr_kind_mod, only: & + i4 => shr_kind_i4, & + i8 => shr_kind_i8, & + r4 => shr_kind_r4, & + r8 => shr_kind_r8, & + cs => shr_kind_cs + +use shr_infnan_mod, only: & + isnan => shr_infnan_isnan + +implicit none +private + +! Human-readable representation of data. +public :: toString + +interface toString + module procedure i4ToString + module procedure i8ToString + module procedure r4ToString + module procedure r8ToString + module procedure logicalToString +end interface toString + +contains + +pure function i4ToString(input, format_string) result(string) + integer(i4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I11)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i4ToString + +pure function i8ToString(input, format_string) result(string) + integer(i8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + ! For most compilers, these two statements are equivalent to a format of + ! '(I0)', but that's not technically in the standard. + write(buffer, '(I20)') input + buffer = adjustl(buffer) + end if + + allocate(string, source=trim(buffer)) + +end function i8ToString + +pure function r4ToString(input, format_string) result(string) + real(r4), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES15.8 E2)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r4ToString + +pure function r8ToString(input, format_string) result(string) + real(r8), intent(in) :: input + character(len=*), intent(in), optional :: format_string + character(len=:), allocatable :: string + + character(len=cs) :: buffer + + if (present(format_string)) then + write(buffer, format_string) input + else + write(buffer, '(ES24.16 E3)') input + buffer = adjustl(buffer) + ! Deal with the fact that the "+" sign is optional by simply adding it if + ! it is not present, so that the default format is standardized across + ! compilers. + ! Assumes that compilers do not treat the sign bit on NaN values specially. + if (.not. isnan(input) .and. all(buffer(1:1) /= ["-", "+"])) then + buffer = "+" // trim(buffer) + end if + end if + + allocate(string, source=trim(buffer)) + +end function r8ToString + +pure function logicalToString(input) result(string) + logical, intent(in) :: input + character(len=:), allocatable :: string + + ! We could use a write statement, but this is easier. + allocate(character(len=1) :: string) + if (input) then + string = "T" + else + string = "F" + end if + +end function logicalToString + +end module shr_strconvert_mod diff --git a/share/csm_share/shr/shr_strdata_mod.F90 b/share/csm_share/shr/shr_strdata_mod.F90 new file mode 100644 index 000000000000..ded8b0ab6a3a --- /dev/null +++ b/share/csm_share/shr/shr_strdata_mod.F90 @@ -0,0 +1,1521 @@ +!=============================================================================== +! SVN: $Id: shr_strdata.F90 11584 2008-09-08 03:16:24Z mvertens $ +! SVN: $HeadURL: https://svn-ccsm-models.cgd.ucar.edu/dlnd7/trunk_tags/dlnd7_090320/shr_strdata.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_strdata_mod -- holds data and methods to advance data models +! +! !DESCRIPTION: +! holds data and methods to advance data models +! +! !REVISION HISTORY: +! 2009-Apr-15 - T. Craig initial version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_strdata_mod + + use shr_const_mod, only: SHR_CONST_PI + use shr_kind_mod, only: IN=>SHR_KIND_IN, R8=>SHR_KIND_R8, & + CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, & + CXX=>SHR_KIND_CXX + use shr_sys_mod, only : shr_sys_abort, shr_sys_flush + use shr_mpi_mod, only : shr_mpi_bcast + use shr_file_mod, only : shr_file_getunit, shr_file_freeunit + use shr_log_mod, only: loglev => shr_log_Level + use shr_log_mod, only: logunit => shr_log_Unit + use shr_stream_mod ! stream data type and methods + use shr_string_mod + use shr_map_mod + use shr_cal_mod, only: shr_cal_calendarname, shr_cal_timeSet, & + shr_cal_noleap, shr_cal_gregorian, & + shr_cal_date2ymd, shr_cal_ymd2date + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz, shr_orb_undef_real + use shr_tinterp_mod + + use shr_dmodel_mod ! shr data model stuff + + use shr_mct_mod + use mct_mod ! mct + use perf_mod ! timing + use pio ! pio + use esmf + + implicit none + + private + +! !PUBLIC TYPES: + + public shr_strdata_type + +! !PUBLIC MEMBER FUNCTIONS: + + public shr_strdata_readnml + public shr_strdata_bcastnml + public shr_strdata_restRead + public shr_strdata_restWrite + public shr_strdata_setOrbs + public shr_strdata_print + public shr_strdata_init + public shr_strdata_create + public shr_strdata_advance + public shr_strdata_clean + public shr_strdata_setlogunit + public shr_strdata_pioinit + +! !PUBLIC DATA MEMBERS: + + +! !PRIVATE: + + integer(IN),parameter :: nStrMax = 30 + integer(IN),parameter :: nVecMax = 30 + character(len=*),public,parameter :: shr_strdata_nullstr = 'null' + character(len=*),parameter :: shr_strdata_unset = 'NOT_SET' + real(R8),parameter,private :: dtlimit_default = 1.5_R8 + + type shr_strdata_type + ! --- set by input --- + character(CL) :: dataMode ! flags physics options wrt input data + character(CL) :: domainFile ! file containing domain info + character(CL) :: streams (nStrMax) ! stream description file names + character(CL) :: taxMode (nStrMax) ! time axis cycling mode + real(R8) :: dtlimit (nStrMax) ! dt max/min limit + character(CL) :: vectors (nVecMax) ! define vectors to vector map + character(CL) :: fillalgo(nStrMax) ! fill algorithm + character(CL) :: fillmask(nStrMax) ! fill mask + character(CL) :: fillread(nStrMax) ! fill mapping file to read + character(CL) :: fillwrit(nStrMax) ! fill mapping file to write + character(CL) :: mapalgo (nStrMax) ! scalar map algorithm + character(CL) :: mapmask (nStrMax) ! scalar map mask + character(CL) :: mapread(nStrMax) ! regrid mapping file to read + character(CL) :: mapwrit(nStrMax) ! regrid mapping file to write + character(CL) :: tintalgo(nStrMax) ! time interpolation algorithm + integer(IN) :: io_type + !--- data required by cosz t-interp method, set by user --- + real(R8) :: eccen + real(R8) :: mvelpp + real(R8) :: lambm0 + real(R8) :: obliqr + integer(IN) :: modeldt ! model dt in seconds + ! --- internal, public --- + integer(IN) :: nxg + integer(IN) :: nyg + integer(IN) :: lsize + type(mct_gsmap) :: gsmap + type(mct_ggrid) :: grid + type(mct_avect) :: avs(nStrMax) + ! --- internal --- + type(shr_stream_streamType) :: stream(nStrMax) + type(iosystem_desc_t), pointer :: pio_subsystem => null() + type(io_desc_t) :: pio_iodesc(nStrMax) + integer(IN) :: nstreams ! number of streams + integer(IN) :: strnxg(nStrMax) + integer(IN) :: strnyg(nStrMax) + logical :: dofill(nStrMax) + logical :: domaps(nStrMax) + integer(IN) :: lsizeR(nStrMax) + type(mct_gsmap) :: gsmapR(nStrMax) + type(mct_rearr) :: rearrR(nStrMax) + type(mct_ggrid) :: gridR(nStrMax) + type(mct_avect) :: avRLB(nStrMax) + type(mct_avect) :: avRUB(nStrMax) + type(mct_avect) :: avFUB(nStrMax) + type(mct_avect) :: avFLB(nStrMax) + type(mct_avect) :: avCoszen(nStrMax) ! data assocaited with coszen time interp + type(mct_sMatP) :: sMatPf(nStrMax) + type(mct_sMatP) :: sMatPs(nStrMax) + integer(IN) :: ymdLB(nStrMax),todLB(nStrMax) + integer(IN) :: ymdUB(nStrMax),todUB(nStrMax) + real(R8) :: dtmin(nStrMax) + real(R8) :: dtmax(nStrMax) + integer(IN) :: ymd ,tod + character(CL) :: calendar ! model calendar for ymd,tod + integer(IN) :: nvectors ! number of vectors + integer(IN) :: ustrm (nVecMax) + integer(IN) :: vstrm (nVecMax) + character(CL) :: allocstring + end type shr_strdata_type + + real(R8),parameter,private :: deg2rad = SHR_CONST_PI/180.0_R8 + character(len=*),parameter :: allocstring_value = 'strdata_allocated' + +!=============================================================================== + contains +!=============================================================================== + + subroutine shr_strdata_init(SDAT,mpicom,compid,name,scmmode,scmlon,scmlat, & + gsmap,ggrid,nxg,nyg,calendar) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + integer(IN) ,intent(in) :: compid + character(len=*) ,intent(in),optional :: name + logical ,intent(in),optional :: scmmode + real(R8) ,intent(in),optional :: scmlon + real(R8) ,intent(in),optional :: scmlat + type(mct_gsmap) ,intent(in),optional :: gsmap + type(mct_ggrid) ,intent(in),optional :: ggrid + integer(IN) ,intent(in),optional :: nxg + integer(IN) ,intent(in),optional :: nyg + character(len=*) ,intent(in),optional :: calendar + + integer(IN) :: n,m,k ! generic index + integer(IN) :: nu,nv ! u,v index + integer(IN) :: my_task,npes ! my task, total pes + integer(IN),parameter :: master_task = 0 + character(CS) :: lname ! local name + character(CL) :: filePath ! generic file path + character(CL) :: fileName ! generic file name + character(CS) :: timeName ! domain file: time variable name + character(CS) :: lonName ! domain file: lon variable name + character(CS) :: latName ! domain file: lat variable name + character(CS) :: maskName ! domain file: mask variable name + character(CS) :: areaName ! domain file: area variable name + character(CS) :: uname ! u vector field name + character(CS) :: vname ! v vector field name + character(CXX):: fldList ! list of fields + integer(IN) :: lsize + integer(IN) :: nfiles + integer(IN) :: ierr + integer(IN) :: method + integer(IN), pointer :: dof(:) + type(mct_sMat):: sMati + logical :: lscmmode + + character(len=*),parameter :: subname = "(shr_strdata_init) " + character(*),parameter :: F00 = "('(shr_strdata_init) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_SIZE(mpicom,npes,ierr) + call MPI_COMM_RANK(mpicom,my_task,ierr) + !--- Count streams again in case user made changes --- + if (my_task == master_task) then + do n=1,nStrMax + !--- check if a streams string is defined in strdata + if (trim(SDAT%streams(n)) /= trim(shr_strdata_nullstr)) SDAT%nstreams = max(SDAT%nstreams,n) + !--- check if a filename is defined in the stream + call shr_stream_getNFiles(SDAT%stream(n),nfiles) + if (nfiles > 0) SDAT%nstreams = max(SDAT%nstreams,n) + + if (trim(SDAT%taxMode(n)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(n) = 1.0e30 + end do + SDAT%nvectors = 0 + do n=1,nVecMax + if (trim(SDAT%vectors(n)) /= trim(shr_strdata_nullstr)) SDAT%nvectors = n + end do + endif + + call shr_mpi_bcast(SDAT%nstreams ,mpicom,'nstreams') + call shr_mpi_bcast(SDAT%nvectors ,mpicom,'nvectors') + call shr_mpi_bcast(SDAT%dtlimit ,mpicom,'dtlimit') + + n = 0 + if (present(gsmap)) then + n = n + 1 + endif + if (present(ggrid)) then + n = n + 1 + endif + if (present(nxg)) then + n = n + 1 + endif + if (present(nyg)) then + n = n + 1 + endif + + if ( n == 0 .or. n == 4) then + ! either all set or none set, this is OK + else + write(logunit,*) subname,' ERROR: gsmap, ggrid, nxg, and nyg must be specified together' + call shr_sys_abort(subname//' ERROR: gsmap, ggrid, nxg, nyg set together') + endif + + lscmmode = .false. + if (present(scmmode)) then + lscmmode = scmmode + if (lscmmode) then + if (.not.present(scmlon) .or. .not.present(scmlat)) then + write(logunit,*) subname,' ERROR: scmmode requires scmlon and scmlat' + call shr_sys_abort(subname//' ERROR: scmmode1 lon lat') + endif + endif + endif + + lname = "" + if (present(name)) then + lname = "_"//trim(name) + endif + + if (present(calendar)) then + SDAT%calendar = trim(shr_cal_calendarName(trim(calendar))) + endif + + ! --- initialize streams and stream domains --- + + + do n = 1,SDAT%nstreams + if (my_task == master_task) then + call shr_stream_getDomainInfo(SDAT%stream(n),filePath,fileName,timeName,lonName, & + latName,maskName,areaName) + call shr_stream_getFile(filePath,fileName) + endif + call shr_mpi_bcast(fileName,mpicom) + call shr_mpi_bcast(lonName,mpicom) + call shr_mpi_bcast(latName,mpicom) + call shr_mpi_bcast(maskName,mpicom) + call shr_mpi_bcast(areaName,mpicom) + call shr_dmodel_readgrid(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName) + SDAT%lsizeR(n) = mct_gsmap_lsize(SDAT%gsmapR(n),mpicom) + call mct_gsmap_OrderedPoints(SDAT%gsmapR(n), my_task, dof) + call pio_initdecomp(SDAT%pio_subsystem, pio_double, & + (/SDAT%strnxg(n),SDAT%strnyg(n)/), dof, SDAT%pio_iodesc(n)) + deallocate(dof) + + call shr_mpi_bcast(SDAT%stream(n)%calendar,mpicom) + enddo + + ! --- initialize model domain --- + + if (present(gsmap)) then + SDAT%nxg = nxg + SDAT%nyg = nyg + lsize = mct_gsmap_lsize(gsmap,mpicom) + call mct_gsmap_Copy(gsmap,SDAT%gsmap) + call mct_ggrid_init(SDAT%grid, ggrid, lsize) + call mct_aVect_copy(ggrid%data, SDAT%grid%data) + else + if (trim(SDAT%domainfile) == trim(shr_strdata_nullstr)) then + if (SDAT%nstreams > 0) then + if (my_task == master_task) then + call shr_stream_getDomainInfo(SDAT%stream(1),filePath,fileName,timeName,lonName, & + latName,maskName,areaName) + call shr_stream_getFile(filePath,fileName) + endif + call shr_mpi_bcast(fileName,mpicom) + call shr_mpi_bcast(lonName,mpicom) + call shr_mpi_bcast(latName,mpicom) + call shr_mpi_bcast(maskName,mpicom) + call shr_mpi_bcast(areaName,mpicom) + if (lscmmode) then + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName, & + scmmode=lscmmode,scmlon=scmlon,scmlat=scmlat) + else + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + fileName, compid, mpicom, '1d', lonName, latName, maskName, areaName) + endif + endif + else + if (lscmmode) then + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + SDAT%domainfile, compid, mpicom, '1d', readfrac=.true., & + scmmode=lscmmode,scmlon=scmlon,scmlat=scmlat) + else + call shr_dmodel_readgrid(SDAT%grid,SDAT%gsmap,SDAT%nxg,SDAT%nyg, & + SDAT%domainfile, compid, mpicom, '1d', readfrac=.true.) + endif + endif + endif + SDAT%lsize = mct_gsmap_lsize(SDAT%gsmap,mpicom) + + ! --- setup mapping --- + + do n = 1,SDAT%nstreams + if (shr_dmodel_gGridCompare(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%grid,SDAT%gsmap, & + shr_dmodel_gGridCompareMaskSubset,mpicom) .or. trim(SDAT%fillalgo(n))=='none') then + SDAT%dofill(n) = .false. + else + SDAT%dofill(n) = .true. + endif + if (trim(SDAT%mapmask(n)) == 'dstmask') then + method = shr_dmodel_gGridCompareXYabsMask + else + method = shr_dmodel_gGridCompareXYabs + endif + if (shr_dmodel_gGridCompare(SDAT%gridR(n),SDAT%gsmapR(n),SDAT%grid,SDAT%gsmap, & + method,mpicom,0.01_r8) .or. trim(SDAT%mapalgo(n))=='none') then + SDAT%domaps(n) = .false. + else + SDAT%domaps(n) = .true. + endif + + if (SDAT%dofill(n)) then + if (trim(SDAT%fillread(n)) == trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' calling shr_dmodel_mapSet for fill' + call shr_sys_flush(logunit) + endif + call shr_dmodel_mapSet(SDAT%sMatPf(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + name='mapFill', type='cfill', & + algo=trim(SDAT%fillalgo(n)),mask=trim(SDAT%fillmask(n)),vect='scalar', & + compid=compid,mpicom=mpicom) + if (trim(SDAT%fillwrit(n)) /= trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' writing ',trim(SDAT%fillwrit(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatWritednc(SDAT%sMatPf(n)%Matrix,SDAT%pio_subsystem,sdat%io_type, SDAT%fillwrit(n),compid,mpicom) + endif + else + if (my_task == master_task) then + write(logunit,F00) ' reading ',trim(SDAT%fillread(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatReaddnc(sMati,SDAT%gsmapR(n),SDAT%gsmapR(n),'src', & + filename=trim(SDAT%fillread(n)),mytask=my_task,mpicom=mpicom) + call mct_sMatP_Init(SDAT%sMatPf(n),sMati,SDAT%gsMapR(n),SDAT%gsmapR(n),0, mpicom, compid) + call mct_sMat_Clean(sMati) + endif + endif + if (SDAT%domaps(n)) then + if (trim(SDAT%mapread(n)) == trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' calling shr_dmodel_mapSet for remap' + call shr_sys_flush(logunit) + endif + call shr_dmodel_mapSet(SDAT%sMatPs(n), & + SDAT%gridR(n),SDAT%gsmapR(n),SDAT%strnxg(n),SDAT%strnyg(n), & + SDAT%grid ,SDAT%gsmap ,SDAT%nxg ,SDAT%nyg, & + name='mapScalar', type='remap', & + algo=trim(SDAT%mapalgo(n)),mask=trim(SDAT%mapmask(n)), vect='scalar', & + compid=compid,mpicom=mpicom) + if (trim(SDAT%mapwrit(n)) /= trim(shr_strdata_unset)) then + if (my_task == master_task) then + write(logunit,F00) ' writing ',trim(SDAT%mapwrit(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatWritednc(SDAT%sMatPs(n)%Matrix,sdat%pio_subsystem,sdat%io_type,SDAT%mapwrit(n),compid,mpicom) + endif + else + if (my_task == master_task) then + write(logunit,F00) ' reading ',trim(SDAT%mapread(n)) + call shr_sys_flush(logunit) + endif + call shr_mct_sMatReaddnc(sMati,SDAT%gsmapR(n),SDAT%gsmap,'src', & + filename=trim(SDAT%mapread(n)),mytask=my_task,mpicom=mpicom) + call mct_sMatP_Init(SDAT%sMatPs(n),sMati,SDAT%gsMapR(n),SDAT%gsmap,0, mpicom, compid) + call mct_sMat_Clean(sMati) + endif + else + call mct_rearr_init(SDAT%gsmapR(n), SDAT%gsmap, mpicom, SDAT%rearrR(n)) + endif + enddo + + ! --- setup datatypes --- + + do n = 1,SDAT%nstreams + if (my_task == master_task) then + call shr_stream_getModelFieldList(SDAT%stream(n),fldList) + endif + call shr_mpi_bcast(fldList,mpicom) + call mct_aVect_init(SDAT%avs(n) ,rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avFLB(n),rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avFUB(n),rlist=fldList,lsize=SDAT%lsize) + call mct_aVect_init(SDAT%avRLB(n),rlist=fldList,lsize=SDAT%lsizeR(n)) + call mct_aVect_init(SDAT%avRUB(n),rlist=fldList,lsize=SDAT%lsizeR(n)) + if (trim(SDAT%tintalgo(n)) == 'coszen') then + call mct_aVect_init(SDAT%avCoszen(n),rlist="tavCosz",lsize=SDAT%lsize) + endif + enddo + + ! --- check vectors and compute ustrm,vstrm --- + + do m = 1,SDAT%nvectors + if (.not. shr_string_listIsValid(SDAT%vectors(m))) then + write(logunit,*) trim(subname),' vec fldlist invalid m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fldlist invalid:'//trim(SDAT%vectors(m))) + endif + if (shr_string_listGetNum(SDAT%vectors(m)) /= 2) then + write(logunit,*) trim(subname),' vec fldlist ne 2 m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fldlist ne 2:'//trim(SDAT%vectors(m))) + endif + call shr_string_listGetName(SDAT%vectors(m),1,uname) + call shr_string_listGetName(SDAT%vectors(m),2,vname) + nu = 0 + nv = 0 + do n = 1,SDAT%nstreams + k = mct_aVect_indexRA(SDAT%avRLB(n),trim(uname),perrWith='quiet') + if (k > 0) nu = n + k = mct_aVect_indexRA(SDAT%avRLB(n),trim(vname),perrWith='quiet') + if (k > 0) nv = n + enddo + if (nu == 0 .or. nv == 0) then + write(logunit,*) trim(subname),' vec flds not found m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec flds not found:'//trim(SDAT%vectors(m))) + endif + if (nu /= nv) then + if ((.not. shr_dmodel_gGridCompare(SDAT%gridR(nu),SDAT%gsmapR(nu), & + SDAT%gridR(nv),SDAT%gsmapR(nv), & + shr_dmodel_gGridCompareXYabs,mpicom,0.01_r8)) .or. & + (.not. shr_dmodel_gGridCompare(SDAT%gridR(nu),SDAT%gsmapR(nu), & + SDAT%gridR(nv),SDAT%gsmapR(nv), & + shr_dmodel_gGridCompareMaskZeros,mpicom))) then + write(logunit,*) trim(subname),' vec fld doms not same m=',m,trim(SDAT%vectors(m)) + call shr_sys_abort(subname//': vec fld doms not same:'//trim(SDAT%vectors(m))) + endif + endif + SDAT%ustrm(m) = nu + SDAT%vstrm(m) = nv + enddo + + end subroutine shr_strdata_init + +!=============================================================================== + + subroutine shr_strdata_advance(SDAT,ymd,tod,mpicom,istr,timers) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN),intent(in) :: ymd ! current model date + integer(IN),intent(in) :: tod ! current model date + integer(IN),intent(in) :: mpicom + character(len=*),intent(in),optional :: istr + logical ,intent(in),optional :: timers + + integer(IN) :: n,m,i,k,l,kf ! generic index + integer(IN) :: my_task,npes + integer(IN),parameter :: master_task = 0 + logical :: mssrmlf + logical,allocatable :: newData(:) + integer(IN) :: ierr + integer(IN) :: nu,nv + integer(IN) :: lsize,lsizeR,lsizeF + integer(IN),allocatable :: ymdmod(:) ! modified model dates to handle Feb 29 + integer(IN) :: todmod ! modified model dates to handle Feb 29 + type(mct_avect) :: avRtmp + type(mct_avect) :: avRV,avFV + character(len=32) :: lstr + logical :: ltimers + real(R8) :: flb,fub ! factor for lb and ub + + !--- for cosz method --- + real(R8) :: calday ! julian day of year + real(R8) :: declin ! solar declination (radians) + real(R8) :: eccf ! earth sun distance factor + real(R8),pointer :: lonr(:) ! lon radians + real(R8),pointer :: latr(:) ! lat radians + real(R8),pointer :: cosz(:) ! cosz + real(R8),pointer :: tavCosz(:) ! cosz, time avg over [LB,UB] + real(R8),pointer :: xlon(:),ylon(:) + real(R8),parameter :: solZenMin = 0.001_R8 ! minimum solar zenith angle + + type(ESMF_Time) :: timeLB, timeUB ! lb and ub times + type(ESMF_TimeInterval) :: timeint ! delta time + integer(IN) :: dday ! delta days + real(R8) :: dtime ! delta time + integer(IN) :: uvar,vvar + logical :: someNewData ! newData test + character(CS) :: uname ! u vector field name + character(CS) :: vname ! v vector field name + integer(IN) :: year,month,day ! date year month day + character(len=*),parameter :: timname = "_strd_adv" + integer(IN),parameter :: tadj = 2 + + !----- formats ----- + character(*),parameter :: subname = "(shr_strdata_advance) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (SDAT%nstreams < 1) return + + lstr = '' + if (present(istr)) then + lstr = trim(istr) + endif + + ltimers = .true. + if (present(timers)) then + ltimers = timers + endif + + if (.not.ltimers) call t_adj_detailf(tadj) + + call MPI_COMM_SIZE(mpicom,npes,ierr) + call MPI_COMM_RANK(mpicom,my_task,ierr) + + mssrmlf = .false. + + SDAT%ymd = ymd + SDAT%tod = tod + + if (SDAT%nstreams > 0) then + allocate(newData(SDAT%nstreams)) + allocate(ymdmod(SDAT%nstreams)) + + do n = 1,SDAT%nstreams + ! ------------------------------------------------------- ! + ! tcraig, Oct 11 2010. Mismatching calendars: 4 cases ! + ! ------------------------------------------------------- ! + ! ymdmod and todmod are the ymd and tod to time ! + ! interpolate to. Generally, these are just the model ! + ! date and time. Also, always use the stream calendar ! + ! for time interpolation for reasons described below. ! + ! When there is a calendar mismatch, support Feb 29 in a ! + ! special way as needed to get reasonable values. ! + ! Note that when Feb 29 needs to be treated specially, ! + ! a discontinuity will be introduced. The size of that ! + ! discontinuity will depend on the time series input data.! + ! ------------------------------------------------------- ! + ! (0) The stream calendar and model calendar are ! + ! identical. Proceed in the standard way. ! + ! ------------------------------------------------------- ! + ! (1) If the stream is a no leap calendar and the model ! + ! is gregorian, then time interpolate on the noleap ! + ! calendar. Then if the model date is Feb 29, compute ! + ! stream data for Feb 28 by setting ymdmod and todmod to ! + ! Feb 28. This results in duplicate stream data on ! + ! Feb 28 and Feb 29 and a discontinuity at the start of ! + ! Feb 29. ! + ! This could be potentially updated by using the gregorian! + ! calendar for time interpolation when the input data is ! + ! relatively infrequent (say greater than daily) with the ! + ! following concerns. + ! - The forcing will not be reproduced identically on ! + ! the same day with climatological inputs data ! + ! - Input data with variable input frequency might ! + ! behave funny + ! - An arbitrary discontinuity will be introduced in ! + ! the time interpolation method based upon the ! + ! logic chosen to transition from reproducing Feb 28 ! + ! on Feb 29 and interpolating to Feb 29. ! + ! - The time gradient of data will change by adding a ! + ! day arbitrarily. + ! ------------------------------------------------------- ! + ! (2) If the stream is a gregorian calendar and the model ! + ! is a noleap calendar, then just time interpolate on the ! + ! gregorian calendar. The causes Feb 29 stream data ! + ! to be skipped and will lead to a discontinuity at the ! + ! start of March 1. ! + ! ------------------------------------------------------- ! + ! (3) If the calendars mismatch and neither of the three ! + ! cases above are recognized, then abort. ! + ! ------------------------------------------------------- ! + + ! case(0) + ymdmod(n) = ymd + todmod = tod + if (trim(SDAT%calendar) /= trim(SDAT%stream(n)%calendar)) then + if ((trim(SDAT%calendar) == trim(shr_cal_gregorian)) .and. & + (trim(SDAT%stream(n)%calendar) == trim(shr_cal_noleap))) then + ! case (1), set feb 29 = feb 28 + call shr_cal_date2ymd (ymd,year,month,day) + if (month == 2 .and. day == 29) then + call shr_cal_ymd2date(year,2,28,ymdmod(n)) + endif + else if ((trim(SDAT%calendar) == trim(shr_cal_noleap)) .and. & + (trim(SDAT%stream(n)%calendar) == trim(shr_cal_gregorian))) then + ! case (2), feb 29 input data will be skipped automatically + else + ! case (3), abort + write(logunit,*) trim(subname),' ERROR: mismatch calendar ', & + trim(SDAT%calendar),':',trim(SDAT%stream(n)%calendar) + call shr_sys_abort(trim(subname)//' ERROR: mismatch calendar ') + endif + endif + + call t_barrierf(trim(lstr)//trim(timname)//'_readLBUB_BARRIER',mpicom) + call t_startf(trim(lstr)//trim(timname)//'_readLBUB') + + call shr_dmodel_readLBUB(SDAT%stream(n),SDAT%pio_subsystem,SDAT%io_type,SDAT%pio_iodesc(n), & + ymdmod(n),todmod,mpicom,SDAT%gsmapR(n),& + SDAT%avRLB(n),SDAT%ymdLB(n),SDAT%todLB(n), & + SDAT%avRUB(n),SDAT%ymdUB(n),SDAT%todUB(n),newData(n), & + istr=trim(lstr)//'_readLBUB') + if (newData(n)) then + call shr_cal_date2ymd(SDAT%ymdLB(n),year,month,day) + call shr_cal_timeSet(timeLB,SDAT%ymdLB(n),0,SDAT%stream(n)%calendar) + call shr_cal_timeSet(timeUB,SDAT%ymdUB(n),0,SDAT%stream(n)%calendar) + timeint = timeUB-timeLB + call ESMF_TimeIntervalGet(timeint,StartTimeIn=timeLB,d=dday) + dtime = abs(real(dday,R8) + real(SDAT%todUB(n)-SDAT%todLB(n),R8)/shr_const_cDay) + + SDAT%dtmin(n) = min(SDAT%dtmin(n),dtime) + SDAT%dtmax(n) = max(SDAT%dtmax(n),dtime) + if ((SDAT%dtmax(n)/SDAT%dtmin(n)) > SDAT%dtlimit(n)) then + write(logunit,*) trim(subName),' ERROR: dt limit1 ',SDAT%dtmax(n),SDAT%dtmin(n),SDAT%dtlimit(n) + write(logunit,*) trim(subName),' ERROR: dt limit2 ',SDAT%ymdLB(n),SDAT%todLB(n), & + SDAT%ymdUB(n),SDAT%todUB(n) + call shr_sys_abort(trim(subName)//' ERROR dt limit') + endif + endif + call t_stopf(trim(lstr)//trim(timname)//'_readLBUB') + enddo + + do n = 1,SDAT%nstreams + if (newData(n)) then + + if (SDAT%doFill(n)) then + call t_startf(trim(lstr)//trim(timname)//'_fill') + lsize = mct_aVect_lsize(SDAT%avRLB(n)) + call mct_aVect_init(avRtmp,SDAT%avRLB(n),lsize) + call mct_aVect_copy(SDAT%avRLB(n),avRtmp) + call mct_sMat_avMult(avRtmp,SDAT%sMatPf(n),SDAT%avRLB(n)) + call mct_aVect_copy(SDAT%avRUB(n),avRtmp) + call mct_sMat_avMult(avRtmp,SDAT%sMatPf(n),SDAT%avRUB(n)) + call mct_aVect_clean(avRtmp) + call t_stopf(trim(lstr)//trim(timname)//'_fill') + endif + + if (SDAT%domaps(n)) then + call t_startf(trim(lstr)//trim(timname)//'_map') + call mct_sMat_avMult(SDAT%avRLB(n),SDAT%sMatPs(n),SDAT%avFLB(n)) + call mct_sMat_avMult(SDAT%avRUB(n),SDAT%sMatPs(n),SDAT%avFUB(n)) + call t_stopf(trim(lstr)//trim(timname)//'_map') + else + call t_startf(trim(lstr)//trim(timname)//'_rearr') + call mct_rearr_rearrange(SDAT%avRLB(n),SDAT%avFLB(n),SDAT%rearrR(n)) + call mct_rearr_rearrange(SDAT%avRUB(n),SDAT%avFUB(n),SDAT%rearrR(n)) + call t_stopf(trim(lstr)//trim(timname)//'_rearr') + endif + + endif + enddo + + do m = 1,SDAT%nvectors + nu = SDAT%ustrm(m) + nv = SDAT%vstrm(m) + if ((SDAT%domaps(nu) .or. SDAT%domaps(nv)) .and. & + (newdata(nu) .or. newdata(nv))) then + + call t_startf(trim(lstr)//trim(timname)//'_vect') + call shr_string_listGetName(SDAT%vectors(m),1,uname) + call shr_string_listGetName(SDAT%vectors(m),2,vname) + lsizeR = mct_aVect_lsize(SDAT%avRLB(nu)) + lsizeF = mct_aVect_lsize(SDAT%avFLB(nu)) + call mct_aVect_init(avRV,rlist=SDAT%vectors(m),lsize=lsizeR) + call mct_aVect_init(avFV,rlist=SDAT%vectors(m),lsize=lsizeF) + allocate(xlon(lsizeR)) + allocate(ylon(lsizeF)) + call mct_aVect_exportRattr(SDAT%gridR(nu)%data,'lon',xlon) + call mct_aVect_exportRattr(SDAT%grid %data,'lon',ylon) + xlon = xlon * deg2rad + ylon = ylon * deg2rad + + !--- map LB --- + + uvar = mct_aVect_indexRA(SDAT%avRLB(nu),trim(uname)) + vvar = mct_aVect_indexRA(SDAT%avRLB(nv),trim(vname)) + do i = 1,lsizeR + avRV%rAttr(1,i) = SDAT%avRLB(nu)%rAttr(uvar,i) * cos(xlon(i)) & + -SDAT%avRLB(nv)%rAttr(vvar,i) * sin(xlon(i)) + avRV%rAttr(2,i) = SDAT%avRLB(nu)%rAttr(uvar,i) * sin(xlon(i)) & + +SDAT%avRLB(nv)%rAttr(vvar,i) * cos(xlon(i)) + enddo + call mct_sMat_avMult(avRV,SDAT%sMatPs(nu),avFV) +! --- don't need to recompute uvar and vvar, should be the same +! uvar = mct_aVect_indexRA(SDAT%avFLB(nu),trim(uname)) +! vvar = mct_aVect_indexRA(SDAT%avFLB(nv),trim(vname)) + do i = 1,lsizeF + SDAT%avFLB(nu)%rAttr(uvar,i) = avFV%rAttr(1,i) * cos(ylon(i)) & + +avFV%rAttr(2,i) * sin(ylon(i)) + SDAT%avFLB(nv)%rAttr(vvar,i) = -avFV%rAttr(1,i) * sin(ylon(i)) & + +avFV%rAttr(2,i) * cos(ylon(i)) + enddo + + !--- map UB --- + + uvar = mct_aVect_indexRA(SDAT%avRUB(nu),trim(uname)) + vvar = mct_aVect_indexRA(SDAT%avRUB(nv),trim(vname)) + do i = 1,lsizeR + avRV%rAttr(1,i) = SDAT%avRUB(nu)%rAttr(uvar,i) * cos(xlon(i)) & + -SDAT%avRUB(nv)%rAttr(vvar,i) * sin(xlon(i)) + avRV%rAttr(2,i) = SDAT%avRUB(nu)%rAttr(uvar,i) * sin(xlon(i)) & + +SDAT%avRUB(nv)%rAttr(vvar,i) * cos(xlon(i)) + enddo + call mct_sMat_avMult(avRV,SDAT%sMatPs(nu),avFV) +! --- don't need to recompute uvar and vvar, should be the same +! uvar = mct_aVect_indexRA(SDAT%avFUB(nu),trim(uname)) +! vvar = mct_aVect_indexRA(SDAT%avFUB(nv),trim(vname)) + do i = 1,lsizeF + SDAT%avFUB(nu)%rAttr(uvar,i) = avFV%rAttr(1,i) * cos(ylon(i)) & + +avFV%rAttr(2,i) * sin(ylon(i)) + SDAT%avFUB(nv)%rAttr(vvar,i) = -avFV%rAttr(1,i) * sin(ylon(i)) & + +avFV%rAttr(2,i) * cos(ylon(i)) + enddo + + call mct_aVect_clean(avRV) + call mct_aVect_clean(avFV) + deallocate(xlon,ylon) + + call t_stopf(trim(lstr)//trim(timname)//'_vect') + endif + enddo + + do n = 1,SDAT%nstreams + + !--- method: coszen ------------------------------------------------------- + if (trim(SDAT%tintalgo(n)) == 'coszen') then + call t_startf(trim(lstr)//trim(timname)//'_coszen') + + !--- make sure orb info has been set --- + if (SDAT%eccen == SHR_ORB_UNDEF_REAL) then + call shr_sys_abort(subname//' ERROR in orb params for coszen tinterp') + else if (SDAT%modeldt < 1) then + call shr_sys_abort(subname//' ERROR: model dt < 1 for coszen tinterp') + endif + + !--- allocate avg cosz array --- + lsizeF = mct_aVect_lsize(SDAT%avFLB(n)) + allocate(tavCosz(lsizeF),cosz(lsizeF),lonr(lsizeF),latr(lsizeF)) + + !--- get lat/lon data --- + kf = mct_aVect_indexRA(SDAT%grid%data,'lat') + latr(:) = SDAT%grid%data%rAttr(kf,:) * deg2rad + kf = mct_aVect_indexRA(SDAT%grid%data,'lon') + lonr(:) = SDAT%grid%data%rAttr(kf,:) * deg2rad + + call t_startf(trim(lstr)//trim(timname)//'_coszenC') + cosz = 0.0_r8 + call shr_tInterp_getCosz(cosz,lonr,latr,ymdmod(n),todmod, & + SDAT%eccen,SDAT%mvelpp,SDAT%lambm0,SDAT%obliqr,SDAT%stream(n)%calendar) + call t_stopf(trim(lstr)//trim(timname)//'_coszenC') + + if (newdata(n)) then + !--- compute a new avg cosz --- + call t_startf(trim(lstr)//trim(timname)//'_coszenN') + call shr_tInterp_getAvgCosz(tavCosz,lonr,latr, & + SDAT%ymdLB(n),SDAT%todLB(n), SDAT%ymdUB(n),SDAT%todUB(n), & + SDAT%eccen,SDAT%mvelpp,SDAT%lambm0,SDAT%obliqr,SDAT%modeldt,& + SDAT%stream(n)%calendar) + call mct_avect_importRAttr(SDAT%avCoszen(n),'tavCosz',tavCosz,lsizeF) + call t_stopf(trim(lstr)//trim(timname)//'_coszenN') + else + !--- reuse existing avg cosz --- + call mct_avect_exportRAttr(SDAT%avCoszen(n),'tavCosz',tavCosz) + endif + + !--- t-interp is LB data normalized with this factor: cosz/tavCosz --- + do i = 1,lsizeF + if (cosz(i) > solZenMin) then + SDAT%avs(n)%rAttr(:,i) = SDAT%avFLB(n)%rAttr(:,i)*cosz(i)/tavCosz(i) + else + SDAT%avs(n)%rAttr(:,i) = 0._r8 + endif + enddo + deallocate(tavCosz,cosz,lonr,latr) + call t_stopf(trim(lstr)//trim(timname)//'_coszen') + + !--- method: not coszen --------------------------------------------------- + elseif (trim(SDAT%tintalgo(n)) /= trim(shr_strdata_nullstr)) then + + call t_startf(trim(lstr)//trim(timname)//'_tint') + call shr_tInterp_getFactors(SDAT%ymdlb(n),SDAT%todlb(n),SDAT%ymdub(n),SDAT%todub(n), & + ymdmod(n),todmod,flb,fub, & + calendar=SDAT%stream(n)%calendar,algo=trim(SDAT%tintalgo(n))) + SDAT%avs(n)%rAttr(:,:) = SDAT%avFLB(n)%rAttr(:,:)*flb + SDAT%avFUB(n)%rAttr(:,:)*fub + call t_stopf(trim(lstr)//trim(timname)//'_tint') + + else + call t_startf(trim(lstr)//trim(timname)//'_zero') + call mct_avect_zero(SDAT%avs(n)) + call t_stopf(trim(lstr)//trim(timname)//'_zero') + endif + enddo + + deallocate(newData) + deallocate(ymdmod) + + endif ! nstreams > 0 + + if (.not.ltimers) call t_adj_detailf(-tadj) + + end subroutine shr_strdata_advance + +!=============================================================================== + subroutine shr_strdata_clean(SDAT) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + + integer(IN) :: n + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_clean) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (SDAT%nxg * SDAT%nyg == 0) then + return + endif + + ! Free MCT and PIO data first, while we still know which objects were + ! allocated for which streams. + call mct_ggrid_clean(SDAT%grid) + call mct_gsmap_clean(SDAT%gsmap) + + do n = 1, SDAT%nstreams + call pio_freedecomp(SDAT%pio_subsystem, SDAT%pio_iodesc(n)) + call mct_avect_clean(SDAT%avs(n)) + call mct_avect_clean(SDAT%avRLB(n)) + call mct_avect_clean(SDAT%avRUB(n)) + call mct_avect_clean(SDAT%avFLB(n)) + call mct_avect_clean(SDAT%avFUB(n)) + call mct_ggrid_clean(SDAT%gridR(n)) + if (SDAT%dofill(n)) call mct_sMatP_clean(SDAT%sMatPf(n)) + if (SDAT%domaps(n)) call mct_sMatP_clean(SDAT%sMatPs(n)) + call mct_gsmap_clean(SDAT%gsmapR(n)) + end do + + ! Now that all sub-objects are freed, clear components of the strdata + ! object itself. + SDAT%nxg = 0 + SDAT%nyg = 0 + SDAT%strnxg = 0 + SDAT%strnyg = 0 + + SDAT%nstreams = 0 + SDAT%nvectors = 0 + SDAT%ustrm = 0 + SDAT%vstrm = 0 + + SDAT%dofill = .false. + SDAT%domaps = .false. + + end subroutine shr_strdata_clean + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_restWrite(filename,SDAT,mpicom,str1,str2) + + implicit none + + character(len=*) ,intent(in) :: filename + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + character(len=*) ,intent(in) :: str1 + character(len=*) ,intent(in) :: str2 + + !--- local ---- + type(shr_stream_streamtype),pointer :: streams(:) + integer(IN) :: n,my_task,ier + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_restWrite) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ier) + + if (my_task == 0) then + call shr_stream_restWrite(SDAT%stream,trim(filename),trim(str1),trim(str2),SDAT%nstreams) + endif + + end subroutine shr_strdata_restWrite + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_restRead(filename,SDAT,mpicom) + + implicit none + + character(len=*) ,intent(in) :: filename + type(shr_strdata_type),intent(inout) :: SDAT + integer(IN) ,intent(in) :: mpicom + + !--- local ---- + type(shr_stream_streamtype),pointer :: streams(:) + integer(IN) :: n,my_task,ier + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_restRead) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call MPI_COMM_RANK(mpicom,my_task,ier) + + if (my_task == 0) then + call shr_stream_restRead(SDAT%stream,trim(filename),SDAT%nstreams) + endif + + end subroutine shr_strdata_restRead + +!=============================================================================== +!=============================================================================== + subroutine shr_strdata_setOrbs(SDAT,eccen,mvelpp,lambm0,obliqr,modeldt) + + implicit none + + type(shr_strdata_type),intent(inout) :: SDAT + real(R8),intent(in) :: eccen + real(R8),intent(in) :: mvelpp + real(R8),intent(in) :: lambm0 + real(R8),intent(in) :: obliqr + integer(IN),intent(in) :: modeldt + + !----- formats ----- + character(len=*),parameter :: subname = "(shr_strdata_setOrbs) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + SDAT%eccen = eccen + SDAT%mvelpp = mvelpp + SDAT%lambm0 = lambm0 + SDAT%obliqr = obliqr + SDAT%modeldt = modeldt + + end subroutine shr_strdata_setOrbs + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_readnml -- read control strdata +! +! !DESCRIPTION: +! Reads strdata common to all data models +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_readnml(SDAT,file,rc,mpicom) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + character(*),optional ,intent(in) :: file ! file to read strdata from + integer(IN),optional ,intent(out) :: rc ! return code + integer(IN),optional ,intent(in) :: mpicom ! mpi comm + +!EOP + + integer(IN) :: rCode ! return code + integer(IN) :: nUnit ! fortran i/o unit number + integer(IN) :: n ! generic loop index + integer(IN) :: my_task ! my task number, 0 is default + integer(IN) :: master_task ! master task number, 0 is default + integer(IN) :: ntasks ! total number of tasks + + !----- temporary/local namelist vars to read int ----- + character(CL) :: dataMode ! flags physics options wrt input data + character(CL) :: domainFile ! file containing domain info + character(CL) :: streams(nStrMax) ! stream description file names + character(CL) :: taxMode(nStrMax) ! time axis cycling mode + real(R8) :: dtlimit(nStrMax) ! delta time limiter + character(CL) :: vectors(nVecMax) ! define vectors to vector map + character(CL) :: fillalgo(nStrMax) ! fill algorithm + character(CL) :: fillmask(nStrMax) ! fill mask + character(CL) :: fillread(nStrMax) ! fill mapping file to read + character(CL) :: fillwrite(nStrMax)! fill mapping file to write + character(CL) :: mapalgo(nStrMax) ! scalar map algorithm + character(CL) :: mapmask(nStrMax) ! scalar map mask + character(CL) :: mapread(nStrMax) ! regrid mapping file to read + character(CL) :: mapwrite(nStrMax) ! regrid mapping file to write + character(CL) :: tintalgo(nStrMax) ! time interpolation algorithm + character(CL) :: io_type + integer(IN) :: num_iotasks + integer(IN) :: io_root + integer(IN) :: io_stride + integer(IN) :: num_agg + character(CL) :: fileName ! generic file name + integer(IN) :: yearFirst ! first year to use in data stream + integer(IN) :: yearLast ! last year to use in data stream + integer(IN) :: yearAlign ! data year that aligns with yearFirst + + !----- define namelist ----- + namelist / shr_strdata_nml / & + dataMode & + , domainFile & + , streams & + , taxMode & + , dtlimit & + , vectors & + , fillalgo & + , fillmask & + , fillread & + , fillwrite & + , mapalgo & + , mapmask & + , mapread & + , mapwrite & + , tintalgo + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_readnml) " + character(*),parameter :: F00 = "('(shr_strdata_readnml) ',8a)" + character(*),parameter :: F01 = "('(shr_strdata_readnml) ',a,i6,a)" + character(*),parameter :: F02 = "('(shr_strdata_readnml) ',a,es13.6)" + character(*),parameter :: F03 = "('(shr_strdata_readnml) ',a,l6)" + character(*),parameter :: F04 = "('(shr_strdata_readnml) ',a,i2,a,a)" + character(*),parameter :: F20 = "('(shr_strdata_readnml) ',a,i6,a)" + character(*),parameter :: F90 = "('(shr_strdata_readnml) ',58('-'))" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (present(rc)) rc = 0 + + my_task = 0 + master_task = 0 + ntasks = 1 + if (present(mpicom)) then + call MPI_COMM_RANK(mpicom,my_task,rCode) + call MPI_COMM_SIZE(mpicom,ntasks,rCode) + endif + +!--master--task-- + if (my_task == master_task) then + + !---------------------------------------------------------------------------- + ! set default values for namelist vars + !---------------------------------------------------------------------------- + dataMode = 'NULL' + domainFile = trim(shr_strdata_nullstr) + streams(:) = trim(shr_strdata_nullstr) + taxMode(:) = trim(shr_stream_taxis_cycle) + dtlimit(:) = dtlimit_default + vectors(:) = trim(shr_strdata_nullstr) + fillalgo(:) = 'nn' + fillmask(:) = 'nomask' + fillread(:) = trim(shr_strdata_unset) + fillwrite(:)= trim(shr_strdata_unset) + mapalgo(:) = 'bilinear' + mapmask(:) = 'dstmask' + mapread(:) = trim(shr_strdata_unset) + mapwrite(:) = trim(shr_strdata_unset) + tintalgo(:) = 'linear' + + + !---------------------------------------------------------------------------- + ! read input namelist + !---------------------------------------------------------------------------- + if (present(file)) then + write(logunit,F00) 'reading input namelist file: ',trim(file) + call shr_sys_flush(logunit) + nUnit = shr_file_getUnit() ! get unused fortran i/o unit number + open (nUnit,file=trim(file),status="old",action="read") + read (nUnit,nml=shr_strdata_nml,iostat=rCode) + close(nUnit) + call shr_file_freeUnit(nUnit) + if (rCode > 0) then + write(logunit,F01) 'ERROR: reading input namelist, '//trim(file)//' iostat=',rCode + call shr_sys_abort(subName//": namelist read error "//trim(file)) + end if + endif + + !---------------------------------------------------------------------------- + ! copy temporary/local namelist vars into data structure + !---------------------------------------------------------------------------- + SDAT%nstreams = 0 + do n=1,nStrMax + call shr_stream_default(SDAT%stream(n)) + enddo + SDAT%dataMode = dataMode + SDAT%domainFile = domainFile + SDAT%streams(:) = streams(:) + SDAT%taxMode(:) = taxMode(:) + SDAT%dtlimit(:) = dtlimit(:) + SDAT%vectors(:) = vectors(:) + SDAT%fillalgo(:) = fillalgo(:) + SDAT%fillmask(:) = fillmask(:) + SDAT%fillread(:) = fillread(:) + SDAT%fillwrit(:) = fillwrite(:) + SDAT%mapalgo(:) = mapalgo(:) + SDAT%mapmask(:) = mapmask(:) + SDAT%mapread(:) = mapread(:) + SDAT%mapwrit(:) = mapwrite(:) + SDAT%tintalgo(:) = tintalgo(:) + do n=1,nStrMax + if (trim(streams(n)) /= trim(shr_strdata_nullstr)) SDAT%nstreams = max(SDAT%nstreams,n) + if (trim(SDAT%taxMode(n)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(n) = 1.0e30 + end do + SDAT%nvectors = 0 + do n=1,nVecMax + if (trim(vectors(n)) /= trim(shr_strdata_nullstr)) SDAT%nvectors = n + end do + + do n = 1,SDAT%nstreams + call shr_stream_parseInput(SDAT%streams(n),fileName,yearAlign,yearFirst,yearLast) + call shr_stream_init(SDAT%stream(n),fileName,yearFirst,yearLast,yearAlign, & + trim(SDAT%taxMode(n))) + enddo + +! call shr_strdata_print(SDAT,trim(file)//' NML_ONLY') + + endif ! master_task +!--master--task-- + + if (present(mpicom)) then + call shr_strdata_bcastnml(SDAT,mpicom) + endif + + SDAT%ymdLB = -1 + SDAT%todLB = -1 + SDAT%ymdUB = -1 + SDAT%todUB = -1 + SDAT%dtmin = 1.0e30 + SDAT%dtmax = 0.0 + SDAT%nxg = 0 + SDAT%nyg = 0 + SDAT%eccen = SHR_ORB_UNDEF_REAL + SDAT%mvelpp = SHR_ORB_UNDEF_REAL + SDAT%lambm0 = SHR_ORB_UNDEF_REAL + SDAT%obliqr = SHR_ORB_UNDEF_REAL + SDAT%modeldt = 0 + SDAT%calendar = shr_cal_noleap + +end subroutine shr_strdata_readnml + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_pioinit -- initialize pio layer +! +! !DESCRIPTION: +! Initialize PIO for a component model +! +! !REVISION HISTORY: +! 2010-10-26 Jim Edwards +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_strdata_pioinit(SDAT,io_subsystem, io_type ) + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + type(iosystem_desc_t), pointer :: io_subsystem + integer, intent(in) :: io_type + + SDAT%pio_subsystem => io_subsystem + SDAT%io_type=io_type + +end subroutine shr_strdata_pioinit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_create -- set strdata and stream info from interface +! +! !DESCRIPTION: +! Set strdata and stream info from fortran interface. +! Note: When this is called, previous settings are reset to defaults +! and then the values passed are used. +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ +subroutine shr_strdata_create(SDAT, name, mpicom, compid, gsmap, ggrid, nxg, nyg, & +!--- streams stuff required --- + yearFirst, yearLast, yearAlign, offset, & + domFilePath, domFileName, & + domTvarName, domXvarName, domYvarName, domAreaName, domMaskName, & + filePath, filename, fldListFile, fldListModel, & + pio_subsystem, pio_iotype, & +!--- strdata optional --- + taxMode, dtlimit, tintalgo, & + fillalgo, fillmask, fillread, fillwrite, & + mapalgo, mapmask, mapread, mapwrite, & + calendar) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout):: SDAT ! strdata data data-type + character(*) ,intent(in) :: name ! name of strdata + integer(IN) ,intent(in) :: mpicom ! mpi comm + integer(IN) ,intent(in) :: compid + type(mct_gsmap) ,intent(in) :: gsmap + type(mct_ggrid) ,intent(in) :: ggrid + integer(IN) ,intent(in) :: nxg + integer(IN) ,intent(in) :: nyg + + integer(IN) ,intent(in) :: yearFirst ! first year to use + integer(IN) ,intent(in) :: yearLast ! last year to use + integer(IN) ,intent(in) :: yearAlign ! align yearFirst with this model year + integer(IN) ,intent(in) :: offset ! offset in seconds of stream data + character(*) ,intent(in) :: domFilePath ! domain file path + character(*) ,intent(in) :: domFileName ! domain file name + character(*) ,intent(in) :: domTvarName ! domain time dim name + character(*) ,intent(in) :: domXvarName ! domain x dim name + character(*) ,intent(in) :: domYvarName ! domain y dim nam + character(*) ,intent(in) :: domAreaName ! domain area name + character(*) ,intent(in) :: domMaskName ! domain mask name + character(*) ,intent(in) :: filePath ! path to filenames + character(*) ,intent(in) :: filename(:) ! filename for index filenumber + character(*) ,intent(in) :: fldListFile ! file field names, colon delim list + character(*) ,intent(in) :: fldListModel ! model field names, colon delim list + type(iosystem_desc_t), pointer :: pio_subsystem ! PIO subsystem pointer + integer(IN) , intent(in) :: pio_iotype ! PIO file type + + character(*),optional ,intent(in) :: taxMode + real(R8) ,optional ,intent(in) :: dtlimit + character(*),optional ,intent(in) :: fillalgo ! fill algorithm + character(*),optional ,intent(in) :: fillmask ! fill mask + character(*),optional ,intent(in) :: fillread ! fill mapping file to read + character(*),optional ,intent(in) :: fillwrite ! fill mapping file to write + character(*),optional ,intent(in) :: mapalgo ! scalar map algorithm + character(*),optional ,intent(in) :: mapmask ! scalar map mask + character(*),optional ,intent(in) :: mapread ! regrid mapping file to read + character(*),optional ,intent(in) :: mapwrite ! regrid mapping file to write + character(*),optional ,intent(in) :: tintalgo ! time interpolation algorithm + character(*),optional, intent(in) :: calendar + +!EOP + +! --- local --- +! --- formats --- + character(*),parameter :: subName = "(shr_strdata_create) " + character(*),parameter :: F00 = "('(shr_strdata_create) ',8a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + call shr_strdata_readnml(SDAT,mpicom=mpicom) + + SDAT%nstreams = 1 + + call shr_strdata_pioinit(sdat, pio_subsystem, pio_iotype) + + if (present(taxMode)) then + SDAT%taxMode(1) = taxMode + if (trim(SDAT%taxMode(1)) == trim(shr_stream_taxis_extend)) SDAT%dtlimit(1) = 1.0e30 + endif + if (present(dtlimit)) then + SDAT%dtlimit(1) = dtlimit + endif + if (present(fillalgo)) then + SDAT%fillalgo(1) = fillalgo + endif + if (present(fillmask)) then + SDAT%fillmask(1) = fillmask + endif + if (present(fillread)) then + SDAT%fillread(1) = fillread + endif + if (present(fillwrite)) then + SDAT%fillwrit(1) = fillwrite + endif + if (present(mapalgo)) then + SDAT%mapalgo(1) = mapalgo + endif + if (present(mapmask)) then + SDAT%mapmask(1) = mapmask + endif + if (present(mapread)) then + SDAT%mapread(1) = mapread + endif + if (present(mapwrite)) then + SDAT%mapwrit(1) = mapwrite + endif + if (present(tintalgo)) then + SDAT%tintalgo(1) = tintalgo + endif + if (present(mapmask)) then + SDAT%mapmask(1) = mapmask + endif + if (present(calendar)) then + SDAT%calendar = trim(shr_cal_calendarName(trim(calendar))) + endif + + call shr_stream_set(SDAT%stream(1),yearFirst,yearLast,yearAlign,offset,taxMode, & + fldListFile,fldListModel,domFilePath,domFileName, & + domTvarName,domXvarName,domYvarName,domAreaName,domMaskName, & + filePath,filename,trim(name)) + + call shr_strdata_init(SDAT, mpicom, compid, & + gsmap=gsmap, ggrid=ggrid, nxg=nxg, nyg=nyg) + +end subroutine shr_strdata_create + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_print -- read control strdata +! +! !DESCRIPTION: +! Reads strdata common to all data models +! +! !REVISION HISTORY: +! 2004-Dec-15 - J. Schramm - first version +! 2009-Apr-16 - T. Craig - add minimal parallel support +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_print(SDAT,name) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type) ,intent(in) :: SDAT ! strdata data data-type + character(len=*),optional,intent(in) :: name ! just a name for tracking + +!EOP + + integer(IN) :: n + character(CL) :: lname + + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_print) " + character(*),parameter :: F00 = "('(shr_strdata_print) ',8a)" + character(*),parameter :: F01 = "('(shr_strdata_print) ',a,i6,a)" + character(*),parameter :: F02 = "('(shr_strdata_print) ',a,es13.6)" + character(*),parameter :: F03 = "('(shr_strdata_print) ',a,l6)" + character(*),parameter :: F04 = "('(shr_strdata_print) ',a,i2,a,a)" + character(*),parameter :: F05 = "('(shr_strdata_print) ',a,i2,a,i6)" + character(*),parameter :: F06 = "('(shr_strdata_print) ',a,i2,a,l2)" + character(*),parameter :: F07 = "('(shr_strdata_print) ',a,i2,a,es13.6)" + character(*),parameter :: F20 = "('(shr_strdata_print) ',a,i6,a)" + character(*),parameter :: F90 = "('(shr_strdata_print) ',58('-'))" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lname = 'unknown' + if (present(name)) then + lname = trim(name) + endif + !---------------------------------------------------------------------------- + ! document datatype settings + !---------------------------------------------------------------------------- + write(logunit,F90) + write(logunit,F00) "name = ",trim(lname) + write(logunit,F00) "dataMode = ",trim(SDAT%dataMode) + write(logunit,F00) "domainFile = ",trim(SDAT%domainFile) + write(logunit,F01) "nxg = ",SDAT%nxg + write(logunit,F01) "nyg = ",SDAT%nyg + write(logunit,F00) "calendar = ",trim(SDAT%calendar) + write(logunit,F01) "io_type = ",SDAT%io_type + write(logunit,F02) "eccen = ",SDAT%eccen + write(logunit,F02) "mvelpp = ",SDAT%mvelpp + write(logunit,F02) "lambm0 = ",SDAT%lambm0 + write(logunit,F02) "obliqr = ",SDAT%obliqr + write(logunit,F01) "nstreams = ",SDAT%nstreams + write(logunit,F01) "pio_iotype = ",sdat%io_type + + do n=1, SDAT%nstreams + write(logunit,F04) " streams (",n,") = ",trim(SDAT%streams(n)) + write(logunit,F04) " taxMode (",n,") = ",trim(SDAT%taxMode(n)) + write(logunit,F07) " dtlimit (",n,") = ",SDAT%dtlimit(n) + write(logunit,F05) " strnxg (",n,") = ",SDAT%strnxg(n) + write(logunit,F05) " strnyg (",n,") = ",SDAT%strnyg(n) + write(logunit,F06) " dofill (",n,") = ",SDAT%dofill(n) + write(logunit,F04) " fillalgo(",n,") = ",trim(SDAT%fillalgo(n)) + write(logunit,F04) " fillmask(",n,") = ",trim(SDAT%fillmask(n)) + write(logunit,F04) " fillread(",n,") = ",trim(SDAT%fillread(n)) + write(logunit,F04) " fillwrit(",n,") = ",trim(SDAT%fillwrit(n)) + write(logunit,F06) " domaps (",n,") = ",SDAT%domaps(n) + write(logunit,F04) " mapalgo (",n,") = ",trim(SDAT%mapalgo(n)) + write(logunit,F04) " mapmask (",n,") = ",trim(SDAT%mapmask(n)) + write(logunit,F04) " mapread (",n,") = ",trim(SDAT%mapread(n)) + write(logunit,F04) " mapwrit (",n,") = ",trim(SDAT%mapwrit(n)) + write(logunit,F04) " tintalgo(",n,") = ",trim(SDAT%tintalgo(n)) + write(logunit,F01) " " + end do + write(logunit,F01) "nvectors = ",SDAT%nvectors + do n=1, SDAT%nvectors + write(logunit,F04) " vectors (",n,") = ",trim(SDAT%vectors(n)) + end do + write(logunit,F90) + call shr_sys_flush(logunit) + +end subroutine shr_strdata_print + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_strdata_bcastnml -- broadcast control strdata +! +! !DESCRIPTION: +! Broadcast strdata +! +! !REVISION HISTORY: +! 2009-Apr-16 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_strdata_bcastnml(SDAT,mpicom,rc) + + use shr_mpi_mod, only : shr_mpi_bcast + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_strdata_type),intent(inout) :: SDAT ! strdata data data-type + integer(IN) ,intent(in) :: mpicom ! mpi communicator + integer(IN),optional ,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(IN) :: lrc + + !----- formats ----- + character(*),parameter :: subName = "(shr_strdata_bcastnml) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lrc = 0 + + call shr_mpi_bcast(SDAT%dataMode ,mpicom,'dataMode') + call shr_mpi_bcast(SDAT%domainFile,mpicom,'domainFile') + call shr_mpi_bcast(SDAT%calendar ,mpicom,'calendar') + call shr_mpi_bcast(SDAT%nstreams ,mpicom,'nstreams') + call shr_mpi_bcast(SDAT%nvectors ,mpicom,'nvectors') + call shr_mpi_bcast(SDAT%streams ,mpicom,'streams') + call shr_mpi_bcast(SDAT%taxMode ,mpicom,'taxMode') + call shr_mpi_bcast(SDAT%dtlimit ,mpicom,'dtlimit') + call shr_mpi_bcast(SDAT%vectors ,mpicom,'vectors') + call shr_mpi_bcast(SDAT%fillalgo ,mpicom,'fillalgo') + call shr_mpi_bcast(SDAT%fillmask ,mpicom,'fillmask') + call shr_mpi_bcast(SDAT%fillread ,mpicom,'fillread') + call shr_mpi_bcast(SDAT%fillwrit ,mpicom,'fillwrit') + call shr_mpi_bcast(SDAT%mapalgo ,mpicom,'mapalgo') + call shr_mpi_bcast(SDAT%mapmask ,mpicom,'mapmask') + call shr_mpi_bcast(SDAT%mapread ,mpicom,'mapread') + call shr_mpi_bcast(SDAT%mapwrit ,mpicom,'mapwrit') + call shr_mpi_bcast(SDAT%tintalgo ,mpicom,'tintalgo') + + if (present(rc)) then + rc = lrc + endif + +end subroutine shr_strdata_bcastnml + +!=============================================================================== + +subroutine shr_strdata_setlogunit(nu) + + integer(IN),intent(in) :: nu + character(len=*),parameter :: subname = "(shr_strdata_setlogunit) " + + ! tcx DOES NOTHING, REMOVE + +end subroutine shr_strdata_setlogunit + +!=============================================================================== +!=============================================================================== + +end module shr_strdata_mod + diff --git a/share/csm_share/shr/shr_stream_mod.F90 b/share/csm_share/shr/shr_stream_mod.F90 new file mode 100644 index 000000000000..47d8635d3941 --- /dev/null +++ b/share/csm_share/shr/shr_stream_mod.F90 @@ -0,0 +1,3118 @@ +!=============================================================================== +! SVN $Id: shr_stream_mod.F90 65656 2014-11-21 18:33:26Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_stream_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_stream_mod -- Data type and methods to manage input data streams. +! +! !DESCRIPTION: +! A "data stream" is a sequence of input files where each file contains the +! same set of data fields and all the data fields are on the same grid. +! The sequence of input data files provides an uninterupted time series of +! data. +! +! A stream data type stores information about one data stream, including the +! range of data date years to use and how data dates align with model dates. +! +! Given a model date, this module can return data dates that are upper and +! lower time bounds around the given model date and the names of the files +! containing those dates. +! +! !REMARKS: +! +! !REVISION HISTORY: +! 2005-Apr-13 - B. Kauffman - moved code from dshr to shr +! 2005-Apr-01 - B. Kauffman - first functional version of findBounds +! 2004-Dec-xx - B. Kauffman - initial module +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_stream_mod + + use shr_sys_mod ! shared system calls + use shr_kind_mod ! kinds for strong typing + use shr_const_mod ! shared constants (including seconds per day) + use shr_string_mod ! string & list methods + use shr_mpi_mod ! shared mpi + use shr_file_mod ! file methods + use shr_cal_mod ! calendar methods + + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_log_mod, only : s_logunit => shr_log_Unit + use shr_log_mod, only : OOBMsg => shr_log_OOBMsg + use perf_mod + + implicit none + + private ! default private + +! !PUBLIC TYPES: + + public :: shr_stream_streamType ! stream data type with private components + public :: shr_stream_fileType + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_stream_init ! initialize a stream + public :: shr_stream_set ! set stream values + public :: shr_stream_default ! set default values + public :: shr_stream_parseInput ! extract fileName,yearAlign, etc. from a string + public :: shr_stream_findBounds ! return lower/upper bounding date info + public :: shr_stream_getFileFieldList ! return input-file field name list + public :: shr_stream_getModelFieldList ! return model field name list + public :: shr_stream_getFileFieldName ! return k-th input-file field name + public :: shr_stream_getModelFieldName ! return k-th model field name list + public :: shr_stream_getFirstFileName ! return the 1st file name in stream + public :: shr_stream_getNextFileName ! return next file in sequence + public :: shr_stream_getPrevFileName ! return previous file in sequence + public :: shr_stream_getFilePath ! return file path + public :: shr_stream_getDataSource ! return the stream's meta data + public :: shr_stream_getDomainInfo ! return the stream's domain info data + public :: shr_stream_getFile ! acquire file, return name of file to open + public :: shr_stream_getNFiles ! get the number of files in a stream + public :: shr_stream_getCalendar ! get the stream calendar + public :: shr_stream_dataDump ! internal stream data for debugging + public :: shr_stream_restWrite ! write a streams restart file + public :: shr_stream_restRead ! read a streams restart file + public :: shr_stream_setDebug ! set internal shr_stream debug level + public :: shr_stream_setAbort ! set internal shr_stream abort flag + public :: shr_stream_getDebug ! get internal shr_stream debug level + public :: shr_stream_isInit ! check if stream is initialized +! public :: shr_stream_bcast ! broadcast a stream (untested) + +! !PUBLIC DATA MEMBERS: + + ! none + +!EOP + + character(SHR_KIND_CS),parameter,public :: shr_stream_taxis_cycle = 'cycle' + character(SHR_KIND_CS),parameter,public :: shr_stream_taxis_extend = 'extend' + character(SHR_KIND_CS),parameter,public :: shr_stream_taxis_limit = 'limit' + character(SHR_KIND_CS),parameter,public :: shr_stream_file_null = 'not_set' + + !--- a useful derived type to use inside shr_stream_streamType --- + type shr_stream_fileType + character(SHR_KIND_CL) :: name = shr_stream_file_null ! the file name + logical :: haveData = .false. ! has t-coord data been read in? + integer (SHR_KIND_IN) :: nt = 0 ! size of time dimension +#ifdef CPRCRAY + integer (SHR_KIND_IN),pointer :: date(:) ! t-coord date: yyyymmdd + integer (SHR_KIND_IN),pointer :: secs(:) ! t-coord secs: elapsed on date +#else + integer (SHR_KIND_IN),allocatable :: date(:) ! t-coord date: yyyymmdd + integer (SHR_KIND_IN),allocatable :: secs(:) ! t-coord secs: elapsed on date +#endif + end type shr_stream_fileType + +! Define a dynamic vector for shr_stream_fileType +#define VECTOR_NAME fileVector +#define TYPE_NAME type(shr_stream_fileType) +#define THROW(string) call shr_sys_abort(string) + +#include "dynamic_vector_typedef.inc" + + type shr_stream_streamType + !private ! no public access to internal components + !--- input data file names and data --- + logical :: init ! has stream been initialized? + integer (SHR_KIND_IN),pointer :: initarr(:) => null()! surrogate for init flag + integer (SHR_KIND_IN) :: nFiles ! number of data files + character(SHR_KIND_CS) :: dataSource ! meta data identifying data source + character(SHR_KIND_CL) :: filePath ! remote location of data files + type(shr_stream_fileType), allocatable :: file(:) ! data specific to each file + + !--- specifies how model dates align with data dates --- + integer(SHR_KIND_IN) :: yearFirst ! first year to use in t-axis (yyyymmdd) + integer(SHR_KIND_IN) :: yearLast ! last year to use in t-axis (yyyymmdd) + integer(SHR_KIND_IN) :: yearAlign ! align yearFirst with this model year + integer(SHR_KIND_IN) :: offset ! offset in seconds of stream data + character(SHR_KIND_CS) :: taxMode ! cycling option for time axis + + !--- useful for quicker searching --- + integer(SHR_KIND_IN) :: k_lvd,n_lvd ! file/sample of least valid date + logical :: found_lvd ! T <=> k_lvd,n_lvd have been set + integer(SHR_KIND_IN) :: k_gvd,n_gvd ! file/sample of greatest valid date + logical :: found_gvd ! T <=> k_gvd,n_gvd have been set + + !--- stream data not used by stream module itself --- + character(SHR_KIND_CXX):: fldListFile ! field list: file's field names + character(SHR_KIND_CXX):: fldListModel ! field list: model's field names + character(SHR_KIND_CL) :: domFilePath ! domain file: file path of domain file + character(SHR_KIND_CL) :: domFileName ! domain file: name + character(SHR_KIND_CS) :: domTvarName ! domain file: time-dim var name + character(SHR_KIND_CS) :: domXvarName ! domain file: x-dim var name + character(SHR_KIND_CS) :: domYvarName ! domain file: y-dim var ame + character(SHR_KIND_CS) :: domAreaName ! domain file: area var name + character(SHR_KIND_CS) :: domMaskName ! domain file: mask var name + + character(SHR_KIND_CS) :: tInterpAlgo ! Algorithm to use for time interpolation + character(SHR_KIND_CL) :: calendar ! stream calendar + end type shr_stream_streamType + + !----- parameters ----- + real(SHR_KIND_R8) ,parameter :: spd = SHR_CONST_CDAY ! seconds per day + integer(SHR_KIND_IN),parameter :: initarr_size = 3 ! size of initarr + integer(SHR_KIND_IN),save :: debug = 0 ! edit/turn-on for debug write statements + logical ,save :: doabort = .true. ! flag if abort on error + +!=============================================================================== +contains +!=============================================================================== + +! Complete the dynamic vector definition. +#include "dynamic_vector_procdef.inc" + +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_init -- initialize stream datatype, read description text file +! +! !DESCRIPTION: +! +! !REMARKS: +! should input be via standard Fortran namelist? +! +! !REVISION HISTORY: +! 2007-Sep-17 - B. Kauffman - reworked wrt new streams.txt format +! 2005-Feb-03 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_init(strm,infoFile,yearFirst,yearLast,yearAlign,taxMode,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(out) :: strm ! data stream + character(*) ,intent(in) :: infoFile ! file with stream info, must read + integer (SHR_KIND_IN) ,intent(in) :: yearFirst ! first year to use + integer (SHR_KIND_IN) ,intent(in) :: yearLast ! last year to use + integer (SHR_KIND_IN) ,intent(in) :: yearAlign ! align yearFirst with this model year + character(*) ,optional,intent(in) :: taxMode ! time axis cycling option + integer (SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer (SHR_KIND_IN) :: n ! generic index + character(SHR_KIND_CL) :: str ! string to parse from input data file + integer (SHR_KIND_IN) :: int ! integer to parse from input data file + character(SHR_KIND_CL) :: subStr ! sub-string of interest + integer (SHR_KIND_IN) :: nUnit ! file i/o unit number + character(SHR_KIND_CS) :: startTag ! input file start tag + character(SHR_KIND_CS) :: endTag ! input file end tag + character(SHR_KIND_CS) :: fldNameFile ! field name in data file field list + character(SHR_KIND_CS) :: fldNameModel ! field name in model field list + character(SHR_KIND_CXX):: fldListFile ! list of data file fields, colon delim list + character(SHR_KIND_CXX):: fldListModel ! list of model fields, colon delim list + character(SHR_KIND_CL) :: calendar ! stream calendar + integer (SHR_KIND_IN) :: rCode, rCode2 ! return code + + type(shr_stream_fileType) :: tempFile ! File being constructed. + type(fileVector) :: fileVec ! Vector used to construct file array. + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_init) ' + character(*),parameter :: F00 = "('(shr_stream_init) ',8a)" + +!------------------------------------------------------------------------------- +! notes: +! * should this use standard namelist input? +! * needs more robust error checking +! o yearFirst,yearLast,yearAlign are provided by calling routine +! o parse infoFile for remaining, except for... +! o fileNT,fileDates, & fileSecs, which are initially set to -1, but but are replaced with +! valid values as each file is opened for the first time +!------------------------------------------------------------------------------- + + rCode = 0 + write(s_logunit,F00) 'Reading file ',trim(infoFile) + + call shr_stream_default(strm) + + strm%yearFirst = yearFirst + strm%yearLast = yearLast + strm%yearAlign = yearAlign + if (present(taxMode)) then + strm%taxMode = trim(taxMode) + endif + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading data source' + !----------------------------------------------------------------------------- + + nUnit = shr_file_getUnit() ! get unused unit number + + !--- find start tag --- + startTag = "" + endTag = "" + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ',iostat=rCode) + if (rCode /= 0) goto 999 + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode) + if (rCode /= 0) goto 999 + + !--- read data --- + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + strm%dataSource = str + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * format = ', trim(strm%dataSource) + + close(nUnit) + call shr_file_freeUnit(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading field data variable names' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode) + if (rCode /= 0) goto 999 + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode) + if (rCode /= 0) goto 999 + + !--- read data --- + n=0 + do while (.true.) + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + n=n+1 + if (str(1:len_trim(endTag)) == trim(endTag)) exit + fldNameFile = "" + fldNameModel = "" + read(str,*,iostat=rCode) fldNameFile,fldNameModel + if (len_trim(fldNameFile)==0 .or. len_trim(fldNameModel)==0 ) then + rCode = 1 + write(s_logunit,F00) "ERROR: reading field names" + write(s_logunit,F00) '* fldNameFile = ',trim(fldNameFile) + write(s_logunit,F00) '* fldNameModel = ',trim(fldNameModel) + call shr_stream_abort(subName//"ERROR: reading field names") + end if + if (n==1) then + strm%fldListFile = trim(fldNameFile ) + strm%fldListModel = trim(fldNameModel) + else + strm%fldListFile = trim(strm%fldListFile ) // ":" // trim(fldNameFile ) + strm%fldListModel = trim(strm%fldListModel) // ":" // trim(fldNameModel) + end if + end do + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * file field list = ',trim(strm%fldListFile ) + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * model field list = ',trim(strm%fldListModel) + if (n==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input field names" + call shr_stream_abort(subName//"ERROR: no input field names") + end if + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading time-interpolation alogrithm ' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading offset' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,optionalTag=.true.,rc=rCode2) + if (rCode2 == 0) then + !--- read data --- + read(nUnit,*,END=999) int + strm%offset = int + else + strm%offset = 0 + end if + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * offset ',strm%offset + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading data file path' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + !--- read data --- + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + n = len_trim(str) + if (n>0 .and. str(n:n) /= '/') str(n+1:n+2) = "/ " ! must have trailing slash + if (n==0) str = "./ " ! null path => ./ + strm%FilePath = str + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * data file path = ', trim(strm%FilePath) + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading field data file names' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + !--- read data --- + do while (.true.) + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + if (str(1:len_trim(endTag)) == trim(endTag)) exit + tempFile%name = str + call fileVec%push_back(tempFile) + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * ',trim(str) + end do + strm%nFiles = fileVec%vsize() + ! Move the vector's internal array out into strm%file. + call fileVec%move_out(strm%file) + + if (strm%nFiles==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input file names" + call shr_stream_abort(subName//"ERROR: no input file names") + end if + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading domain data variable names' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + !--- read data --- + n=0 + do while (.true.) + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + n=n+1 + if (str(1:len_trim(endTag)) == trim(endTag)) exit + fldNameFile = "" + fldNameModel = "" + read(str,*,iostat=rCode2) fldNameFile,fldNameModel + if (len_trim(fldNameFile)==0 .or. len_trim(fldNameModel)==0 ) then + rCode = 1 + write(s_logunit,F00) "ERROR: reading field names" + write(s_logunit,F00) '* fldNameFile = ',trim(fldNameFile) + write(s_logunit,F00) '* fldNameModel = ',trim(fldNameModel) + call shr_stream_abort(subName//"ERROR: reading field names") + end if + if (n==1) then + fldListFile = trim(fldNameFile ) + fldListModel = trim(fldNameModel) + else + fldListFile = trim(fldListFile ) // ":" // trim(fldNameFile ) + fldListModel = trim(fldListModel) // ":" // trim(fldNameModel) + end if + end do + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * file field list = ',trim(fldListFile ) + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * model field list = ',trim(fldListModel) + + if (n==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input field names" + call shr_stream_abort(subName//"ERROR: no input field names") + else + !--- get time variable name --- + n = shr_string_listGetIndexF(fldListModel,"time") + if (n==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input field names" + call shr_stream_abort(subName//"ERROR: no time variable name") + else + call shr_string_listGetName (fldListFile,n,substr,rc) + strm%domTvarName = subStr + endif + !--- get longitude variable name --- + n = shr_string_listGetIndexF(fldListModel,"lon") + if (n==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input field names" + call shr_stream_abort(subName//"ERROR: no lon variable name") + else + call shr_string_listGetName (fldListFile,n,substr,rc) + strm%domXvarName = subStr + endif + !--- get latitude variable name --- + n = shr_string_listGetIndexF(fldListModel,"lat") + if (n==0) then + rCode = 1 + write(s_logunit,F00) "ERROR: no input field names" + call shr_stream_abort(subName//"ERROR: no lat variable name") + else + call shr_string_listGetName (fldListFile,n,substr,rc) + strm%domYvarName = subStr + endif + !--- get area variable name --- + n = shr_string_listGetIndexF(fldListModel,"area") + if (n==0) then +! rCode = 1 +! write(s_logunit,F00) "ERROR: no input field names" +! call shr_stream_abort(subName//"ERROR: no area variable name") + strm%domAreaName = 'unknownname' + else + call shr_string_listGetName (fldListFile,n,substr,rc) + strm%domAreaName = subStr + endif + !--- get mask variable name --- + n = shr_string_listGetIndexF(fldListModel,"mask") + if (n==0) then +! rCode = 1 +! write(s_logunit,F00) "ERROR: no input field names" +! call shr_stream_abort(subName//"ERROR: no mask variable name") + strm%domMaskName = 'unknownname' + else + call shr_string_listGetName (fldListFile,n,substr,rc) + strm%domMaskName = subStr + endif + end if + + close(nUnit) + + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading domain data file path' + !----------------------------------------------------------------------------- + + !--- find start tag --- + startTag = "" + endTag = "" + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + !--- read data --- + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + n = len_trim(str) + if (n>0 .and. str(n:n) /= '/') str(n+1:n+2) = "/ " ! must have trailing slash + if (n==0) str = "./ " ! null path => ./ + strm%domFilePath = str + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * data file path = ', trim(strm%domFilePath) + + close(nUnit) + !----------------------------------------------------------------------------- + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' reading domain data file name' + !----------------------------------------------------------------------------- + + !--- find start tag --- + open(nUnit,file=infoFile,STATUS='OLD',FORM='FORMATTED',ACTION='READ') + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + startTag = "" + endTag = "" + call shr_stream_readUpToTag(nUnit,startTag,rc=rCode2) + if (rCode2 /= 0)then + rCode = rCode2 + goto 999 + end if + + !--- read data --- + read(nUnit,'(a)',END=999) str + call shr_string_leftAlign(str) + strm%domFileName = str + if (debug>0 .and. s_loglev>0) write(s_logunit,F00) ' * ',trim(strm%domFileName) + + close(nUnit) + + !----------------------------------------------------------------------------- + ! get initial calendar value + !----------------------------------------------------------------------------- + call shr_stream_getCalendar(strm,1,calendar) + strm%calendar = trim(calendar) + + !----------------------------------------------------------------------------- + ! normal return or end-of-file problem? + !----------------------------------------------------------------------------- + call shr_stream_setInit(strm) + if ( present(rc) ) rc = rCode + call shr_file_freeUnit(nUnit) + return + +999 continue + write(s_logunit,F00) "ERROR: unexpected end-of-file while reading ",trim(startTag) + write(s_logunit,F00) " error code = ", rCode + call shr_stream_abort(subName//"ERROR: unexpected end-of-file") + close(nUnit) + if ( present(rc) ) rc = rCode + call shr_file_freeUnit(nUnit) + +end subroutine shr_stream_init + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_set -- set values of stream datatype +! +! !DESCRIPTION: +! +! !REMARKS: +! set or override stream settings +! +! !REVISION HISTORY: +! 2010-Apr-20 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_set(strm,yearFirst,yearLast,yearAlign,offset,taxMode, & + fldListFile,fldListModel,domFilePath,domFileName, & + domTvarName,domXvarName,domYvarName,domAreaName,domMaskName, & + filePath,filename,dataSource,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(inout) :: strm ! data stream + integer (SHR_KIND_IN),optional,intent(in) :: yearFirst ! first year to use + integer (SHR_KIND_IN),optional,intent(in) :: yearLast ! last year to use + integer (SHR_KIND_IN),optional,intent(in) :: yearAlign ! align yearFirst with this model year + integer (SHR_KIND_IN),optional,intent(in) :: offset ! offset in seconds of stream data + character(*) ,optional,intent(in) :: taxMode ! time axis mode + character(*) ,optional,intent(in) :: fldListFile ! file field names, colon delim list + character(*) ,optional,intent(in) :: fldListModel ! model field names, colon delim list + character(*) ,optional,intent(in) :: domFilePath ! domain file path + character(*) ,optional,intent(in) :: domFileName ! domain file name + character(*) ,optional,intent(in) :: domTvarName ! domain time dim name + character(*) ,optional,intent(in) :: domXvarName ! domain x dim name + character(*) ,optional,intent(in) :: domYvarName ! domain y dim nam + character(*) ,optional,intent(in) :: domAreaName ! domain area name + character(*) ,optional,intent(in) :: domMaskName ! domain mask name + character(*) ,optional,intent(in) :: filePath ! path for filenames + character(*) ,optional,intent(in) :: filename(:) ! input filenames + character(*) ,optional,intent(in) :: dataSource ! comment line + integer (SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n + character(SHR_KIND_CL) :: calendar ! stream calendar + + type(shr_stream_fileType) :: tempFile ! File being constructed. + type(fileVector) :: fileVec ! Vector used to construct file array. + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_set) ' + character(*),parameter :: F00 = "('(shr_stream_set) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_set) ',1a,i6)" + +!------------------------------------------------------------------------------- + + call shr_stream_default(strm) + + if ( present(rc) ) rc = 0 + + if (present(yearFirst)) then + strm%yearFirst = yearFirst + endif + if (present(yearLast)) then + strm%yearLast = yearLast + endif + if (present(yearAlign)) then + strm%yearAlign = yearAlign + endif + if (present(offset)) then + strm%offset = offset + endif + if (present(taxMode)) then + strm%taxMode = trim(taxMode) + endif + if (present(fldListFile)) then + strm%fldListFile = trim(fldListFile) + endif + if (present(fldListModel)) then + strm%fldListModel = trim(fldListModel) + endif + if (present(domFilePath)) then + strm%domFilePath = trim(domFilePath) + endif + if (present(domFileName)) then + strm%domFileName = trim(domFileName) + endif + if (present(domTvarName)) then + strm%domTvarName = trim(domTvarName) + endif + if (present(domXvarName)) then + strm%domXvarName = trim(domXvarName) + endif + if (present(domYvarName)) then + strm%domYvarName = trim(domYvarName) + endif + if (present(domAreaName)) then + strm%domAreaName = trim(domAreaName) + endif + if (present(domMaskName)) then + strm%domMaskName = trim(domMaskName) + endif + if (present(filePath)) then + strm%filePath = trim(filePath) + endif + if (present(filename)) then + !write(s_logunit,F01) "size of filename = ",size(filename) + !write(s_logunit,F00) "filename = ",filename + + do n = 1,size(filename) + ! Ignore null file names. + if (trim(filename(n)) /= trim(shr_stream_file_null)) then + tempFile%name = trim(filename(n)) + call fileVec%push_back(tempFile) + endif + enddo + ! True size after throwing out null names. + strm%nFiles = fileVec%vsize() + call fileVec%move_out(strm%file) + endif + + !----------------------------------------------------------------------------- + ! get initial calendar value + !----------------------------------------------------------------------------- + call shr_stream_getCalendar(strm,1,calendar) + strm%calendar = trim(calendar) + + call shr_stream_setInit(strm) + +end subroutine shr_stream_set + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_default -- set defaults for stream +! +! !DESCRIPTION: +! +! !REMARKS: +! set basic default values for streams +! +! !REVISION HISTORY: +! 2010-Oct-20 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_default(strm,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(inout) :: strm ! data stream + integer (SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_default) ' + character(*),parameter :: F00 = "('(shr_stream_default) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_default) ',1a,i6)" + +!------------------------------------------------------------------------------- + + !----------------------------------------------------------------------------- + ! set default values for everything in stream + !----------------------------------------------------------------------------- + call shr_stream_clearInit(strm) + strm%nFiles = 0 + strm%dataSource = 'undefined' + strm%filePath = ' ' + + if (allocated(strm%file)) deallocate(strm%file) + + strm%yearFirst = 0 + strm%yearLast = 0 + strm%yearAlign = 0 + strm%offset = 0 + strm%taxMode = trim(shr_stream_taxis_cycle) + + strm%k_lvd = -1 + strm%n_lvd = -1 + strm%found_lvd = .false. + strm%k_gvd = -1 + strm%n_gvd = -1 + strm%found_gvd = .false. + + strm%fldListFile = ' ' + strm%fldListModel = ' ' + strm%domFilePath = ' ' + strm%domFileName = ' ' + strm%domTvarName = ' ' + strm%domXvarName = ' ' + strm%domYvarName = ' ' + strm%domAreaName = ' ' + strm%domMaskName = ' ' + + strm%calendar = shr_cal_noleap + + if ( present(rc) ) rc = 0 + +end subroutine shr_stream_default +!=============================================================================== + +subroutine shr_stream_readUpToTag(nUnit,tag,optionalTag,rc) + + !----- input/output ----- + integer(SHR_KIND_IN),intent(in ) :: nUnit ! i/o unit to read from + character(*) ,intent(in ) :: tag ! string to search for + logical, optional ,intent(in ) :: optionalTag ! this is an optional tag + integer(SHR_KIND_IN),intent(out) :: rc ! return code + + !----- local ----- + character(SHR_KIND_CL) :: str ! temp char string + logical :: localOptionalTag ! local version of optionalTag + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_readUpToTag) ' + character(*),parameter :: F00 = "('(shr_stream_readUpToTag) ',8a)" + +!------------------------------------------------------------------------------- +! Note: does not rewind to start of file +!------------------------------------------------------------------------------- + + rc = 1 + localOptionalTag = .false. + if (present(optionalTag)) localOptionalTag = optionalTag + do while (.true.) + read(nUnit,'(a)',END=999) str + str = adjustL(str) + if (str(1:len_trim(adjustL(tag))) == trim(adjustL(tag))) then + rc = 0 + exit + end if + end do + +999 continue + + if (rc /= 0 .and. .not. localOptionalTag ) then + write(s_logunit,F00) "ERROR: tag not found: ",trim(tag) + call shr_stream_abort(subName//"ERROR: tag not found") + end if + +end subroutine shr_stream_readUpToTag + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_parseInput -- extract fileName,yearAlign, etc. from a string +! +! !DESCRIPTION: +! shr_stream_parseInput -- extract fileName,yearAlign, etc. from a string +! +! !REMARKS: +! should input be via standard Fortran namelist? +! +! !REVISION HISTORY: +! 2007-Aug-01 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_parseInput(str,fileName,yearAlign,yearFirst,yearLast,rc) + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: str ! string to parse + character(*) ,intent(out) :: fileName ! file name + integer (SHR_KIND_IN) ,intent(out) :: yearFirst ! first year to use + integer (SHR_KIND_IN) ,intent(out) :: yearLast ! last year to use + integer (SHR_KIND_IN) ,intent(out) :: yearAlign ! align yearFirst with this model year + integer (SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer (SHR_KIND_IN) :: n ! generic index + character(SHR_KIND_CL) :: str2 ! temp work string + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_parseInput) ' + character(*),parameter :: F00 = "('(shr_stream_parseInput) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_parseInput) ',a,3i10)" + +!------------------------------------------------------------------------------- +! notes: +! - this routine exists largely because of the difficulty of reading file names +! that include dir paths, ie. containing "/", from char strings +! because the "/" is interpreted as an end-of-record. +!------------------------------------------------------------------------------- + + if (debug>1 .and. s_loglev > 0) write(s_logunit,F00) "str = ",trim(str) + + str2 = adjustL(str) + n = index(str2," ") + fileName = str2(:n) + read(str2(n:),*) yearAlign,yearFirst,yearLast + + if (debug>1 .and. s_loglev > 0) then + write(s_logunit,F00) "fileName = ",trim(fileName) + write(s_logunit,F01) "yearAlign = ",yearAlign + write(s_logunit,F01) "yearFirst = ",yearFirst + write(s_logunit,F01) "yearLast = ",yearLast + end if + + if (present(rc)) rc = 0 + +end subroutine shr_stream_parseInput + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_findBounds -- find stream data bounding a model date +! +! !DESCRIPTION: +! Given a stream and a model date, find time coordinates of the upper and +! lower time bounds surrounding the models date. Returns the model date, +! data date, elasped seconds, time index, and file names associated with +! these upper and lower time bounds. +! +! !REVISION HISTORY: +! 2009-Sep-01 - T. Craig - modified +! 2005-Apr-01 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_findBounds(strm,mDateIn, secIn, & + & mDateLB,dDateLB,secLB,n_lb,fileLB, & + & mDateUB,dDateUB,secUB,n_ub,fileUB ) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(inout):: strm ! data stream to query + integer(SHR_KIND_IN) ,intent(in) :: mDateIn ! model date (yyyymmdd) + integer(SHR_KIND_IN) ,intent(in) :: secIn ! elapsed sec on model date + integer(SHR_KIND_IN) ,intent(out) :: mDateLB ! model date of LB + integer(SHR_KIND_IN) ,intent(out) :: dDateLB ! data date of LB + integer(SHR_KIND_IN) ,intent(out) :: secLB ! elap sec of LB + integer(SHR_KIND_IN) ,intent(out) :: n_lb ! t-coord index of LB + character(*) ,intent(out) :: fileLB ! file containing LB + integer(SHR_KIND_IN) ,intent(out) :: mDateUB ! model date of UB + integer(SHR_KIND_IN) ,intent(out) :: dDateUB ! data date of UB + integer(SHR_KIND_IN) ,intent(out) :: secUB ! elap sec of UB + integer(SHR_KIND_IN) ,intent(out) :: n_ub ! t-coord index of UB + character(*) ,intent(out) :: fileUB ! file containing UB + +!EOP + + !----- local ----- + character(SHR_KIND_CL) :: fileName ! string + integer (SHR_KIND_IN) :: nt ! size of a time-coord dimension + integer (SHR_KIND_IN) :: dDateIn ! model date mapped onto a data date + integer (SHR_KIND_IN) :: dDateF ! first date + integer (SHR_KIND_IN) :: dDateL ! last date + integer (SHR_KIND_IN) :: n,nf ! loop index wrt t-coord array within one file + integer (SHR_KIND_IN) :: k,kf ! loop index wrt list of files + integer (SHR_KIND_IN) :: k_ub,k_lb ! file index of U/L bounds + integer (SHR_KIND_IN) :: rCode ! return code + + integer (SHR_KIND_IN) :: mYear ! year of model date + integer (SHR_KIND_IN) :: yrFirst ! first year of data loop + integer (SHR_KIND_IN) :: yrLast ! last year of data loop + integer (SHR_KIND_IN) :: yrAlign ! model year that aligns with yearFirst + integer (SHR_KIND_IN) :: nYears ! number of years in data loop + integer (SHR_KIND_IN) :: dYear ! data year corresponding to model year + integer (SHR_KIND_IN) :: yy,mm,dd ! year,month,day + real (SHR_KIND_R8) :: rDateIn ! model dDateIn + secs/(secs per day) + real (SHR_KIND_R8) :: rDate1 ! stream dDateIn + secs/(secs per day) + real (SHR_KIND_R8) :: rDate2 ! stream dDateIn + secs/(secs per day) + real (SHR_KIND_R8) :: rDatelvd ! lvd dDate + secs/(secs per day) + real (SHR_KIND_R8) :: rDategvd ! gvd dDate + secs/(secs per day) + logical :: cycle ! is cycling on or off + logical :: limit ! is limiting on or off + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_findBounds) ' + character(*),parameter :: F00 = "('(shr_stream_findBounds) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_findBounds) ',a,i9.8,a)" + character(*),parameter :: F02 = "('(shr_stream_findBounds) ',a,2i9.8,i6,i5,1x,a)" + character(*),parameter :: F03 = "('(shr_stream_findBounds) ',a,i4)" + character(*),parameter :: F04 = "('(shr_stream_findBounds) ',2a,i4)" + +!------------------------------------------------------------------------------- +! Purpose: +! 1) take the model date, map it into the data date range +! 2) find the upper and lower bounding data dates +! 3) return the bounding data and model dates, file names, & t-coord indicies +!------------------------------------------------------------------------------- + + if (debug>0 .and. s_loglev > 0) write(s_logunit,F02) "DEBUG: ---------- enter ------------------" + + rCode = 0 + if ( .not. shr_stream_isInit(strm)) then + rCode = 1 + call shr_stream_abort(trim(subName)//" ERROR: trying to find bounds of uninitialized stream") + return + end if + + if (trim(strm%taxMode) == trim(shr_stream_taxis_cycle)) then + cycle = .true. + limit = .false. + elseif (trim(strm%taxMode) == trim(shr_stream_taxis_extend)) then + cycle = .false. + limit = .false. + elseif (trim(strm%taxMode) == trim(shr_stream_taxis_limit)) then + cycle = .false. + limit = .true. + else + write(s_logunit,*) trim(subName),' ERROR: illegal taxMode = ',trim(strm%taxMode) + call shr_stream_abort(trim(subName)//' ERROR: illegal taxMode = '//trim(strm%taxMode)) + endif + + !---------------------------------------------------------------------------- + ! convert/map the model year/date into a data year/date + ! note: these values will be needed later to convert data year to model year + !---------------------------------------------------------------------------- + mYear = mDateIn/10000 ! assumes/require F90 truncation + yrFirst = strm%yearFirst ! first year in data sequence + yrLast = strm%yearLast ! last year in data sequence + yrAlign = strm%yearAlign ! model year corresponding to yearFirst + nYears = yrLast - yrFirst + 1 ! number of years in data sequence + dDateF = yrFirst * 10000 + 101 ! first date in valid range + dDateL = (yrLast+1) * 10000 + 101 ! last date in valid range + + if (cycle) then + dYear = yrFirst + modulo(mYear-yrAlign+(2*nYears),nYears) ! current data year + else + dYear = yrFirst + mYear - yrAlign + endif + + if (dYear < 0) then + write(s_logunit,*) trim(subName),' ERROR: dyear lt zero = ',dYear + call shr_stream_abort(trim(subName)//' ERROR: dyear lt one') + endif + + dDateIn = dYear*10000 + modulo(mDateIn,10000) ! mDateIn mapped to range of data years + rDateIn = dDateIn + secIn/spd ! dDateIn + fraction of a day + +! write(s_logunit,*) 'tcx fbd1 ',mYear,dYear,dDateIn,rDateIn +! write(s_logunit,*) 'tcx fbd2 ',yrFirst,yrLast,yrAlign,nYears +! call shr_sys_flush(s_logunit) + + !---------------------------------------------------------------------------- + ! find least valid date (lvd) + !---------------------------------------------------------------------------- + + if (.not. strm%found_lvd) then +A: do k=1,strm%nFiles + if (.not. strm%file(k)%haveData) then + call shr_stream_readtCoord(strm, k, rCode) + if ( rCode /= 0 )then + call shr_stream_abort(trim(subName)//" ERROR: readtCoord1") + return + end if + end if + do n=1,strm%file(k)%nt + if ( dDateF <= strm%file(k)%date(n) ) then + !--- found a date in or beyond yearFirst --- + strm%k_lvd = k + strm%n_lvd = n + strm%found_lvd = .true. + exit A + end if + end do + end do A + if (.not. strm%found_lvd) then + rCode = 1 + write(s_logunit,F00) "ERROR: LVD not found, all data is before yearFirst" + call shr_stream_abort(trim(subName)//" ERROR: LVD not found, all data is before yearFirst") + else + !--- LVD is in or beyond yearFirst, verify it is not beyond yearLast --- + if ( dDateL <= strm%file(strm%k_lvd)%date(strm%n_lvd) ) then + rCode = 1 + write(s_logunit,F00) "ERROR: LVD not found, all data is after yearLast" + call shr_stream_abort(trim(subName)//" ERROR: LVD not found, all data is after yearLast") + end if + end if + if (debug>1 .and. s_loglev > 0) then + if (strm%found_lvd) write(s_logunit,F01) "DEBUG: found LVD = ",strm%file(k)%date(n) + end if + end if + + if (strm%found_lvd) then + k = strm%k_lvd + n = strm%n_lvd + rDatelvd = strm%file(k)%date(n) + strm%file(k)%secs(n)/spd ! LVD date + frac day + else + write(s_logunit,F00) "ERROR: LVD not found yet" + call shr_stream_abort(trim(subName)//" ERROR: LVD not found yet") + endif + + if (strm%found_gvd) then + k = strm%k_gvd + n = strm%n_gvd + rDategvd = strm%file(k)%date(n) + strm%file(k)%secs(n)/spd ! GVD date + frac day + else + rDategvd = 99991231.0 + endif + +! write(s_logunit,*) 'tcx fbd3 ',rDateIn,rDatelvd,rDategvd +! call shr_sys_flush(s_logunit) + + !----------------------------------------------------------- + ! dateIn < rDatelvd + ! limit -> abort + ! extend -> use lvd value, set LB to 00000101 + ! cycle -> lvd is UB, gvd is LB, shift mDateLB by -nYears + !----------------------------------------------------------- + + if (rDateIn < rDatelvd) then + if (limit) then + write(s_logunit,*) trim(subName)," ERROR: limit on and rDateIn lt rDatelvd",rDateIn,rDatelvd + call shr_stream_abort(trim(subName)//" ERROR: rDateIn lt rDatelvd limit true") + return + endif + + if (.not.cycle) then + k_lb = strm%k_lvd + n_lb = strm%n_lvd + dDateLB = 00000101 + mDateLB = 00000101 + secLB = 0 + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_lvd + n_ub = strm%n_lvd + dDateUB = strm%file(k_ub)%date(n_ub) + call shr_cal_date2ymd(dDateUB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateUB) + secUB = strm%file(k_ub)%secs(n_ub) + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb1 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + if (cycle) then + !--- find greatest valid date (GVD) --- + if (.not. strm%found_gvd) then + !--- start search at last file & move toward first file --- +B: do k=strm%nFiles,1,-1 + !--- read data for file number k --- + if (.not. strm%file(k)%haveData) then + call shr_stream_readtCoord(strm, k, rCode) + if ( rCode /= 0 )then + call shr_stream_abort(trim(subName)//" ERROR: readtCoord2") + return + end if + end if + !--- start search at greatest date & move toward least date --- + do n=strm%file(k)%nt,1,-1 + if ( strm%file(k)%date(n) < dDateL ) then + strm%k_gvd = k + strm%n_gvd = n + strm%found_gvd = .true. + rDategvd = strm%file(k)%date(n) + strm%file(k)%secs(n)/spd ! GVD date + frac day + if (debug>1 .and. s_loglev > 0) write(s_logunit,F01) "DEBUG: found GVD ",strm%file(k)%date(n) + exit B + end if + end do + end do B + end if + + if (.not. strm%found_gvd) then + write(s_logunit,F00) "ERROR: GVD not found1" + call shr_stream_abort(trim(subName)//" ERROR: GVD not found1") + endif + + k_lb = strm%k_gvd + n_lb = strm%n_gvd + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear-nYears) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_lvd + n_ub = strm%n_lvd + dDateUB = strm%file(k_ub)%date(n_ub) + call shr_cal_date2ymd(dDateUB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateUB) + secUB = strm%file(k_ub)%secs(n_ub) + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb2 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + !----------------------------------------------------------- + ! dateIn > rDategvd + ! limit -> abort + ! extend -> use gvd value, set UB to 99991231 + ! cycle -> lvd is UB, gvd is LB, shift mDateLB by +nYears + !----------------------------------------------------------- + + else if (strm%found_gvd .and. rDateIn >= rDategvd) then + if (limit) then + write(s_logunit,*) trim(subName)," ERROR: limit on and rDateIn gt rDategvd",rDateIn,rDategvd + call shr_stream_abort(trim(subName)//" ERROR: rDateIn gt rDategvd limit true") + return + endif + + if (.not.cycle) then + k_lb = strm%k_gvd + n_lb = strm%n_gvd + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_gvd + n_ub = strm%n_gvd + dDateUB = 99991231 + mDateUB = 99991231 + secUB = 0 + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb3 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + if (cycle) then + k_lb = strm%k_gvd + n_lb = strm%n_gvd + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_lvd + n_ub = strm%n_lvd + dDateUB = strm%file(k_ub)%date(n_ub) + call shr_cal_date2ymd(dDateUB,yy,mm,dd) + yy = yy + (mYear-dYear+nYears) + call shr_cal_ymd2date(yy,mm,dd,mDateUB) + secUB = strm%file(k_ub)%secs(n_ub) + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb4 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + else + + !----------------------------------------------------------- + ! dateIn > rDatelvd + !----------------------------------------------------------- + k_lb = strm%k_lvd + n_lb = strm%n_lvd +C: do k=strm%k_lvd,strm%nFiles + !--- read data for file number k --- + if (.not. strm%file(k)%haveData) then + call shr_stream_readtCoord(strm, k, rCode) + if ( rCode /= 0 )then + call shr_stream_abort(trim(subName)//" ERROR: readtCoord3") + return + end if + end if + !--- examine t-coords for file k --- + n = strm%file(k)%nt ! last t-index in file + rDate1 = strm%file(k)%date(n) + strm%file(k)%secs(n)/spd ! last date + frac day + + if (.not. strm%found_gvd) then + n = strm%file(k)%nt + if (dDateL <= strm%file(k)%date(n)) then + !--- set gvd to last timestep in previous file then advance through current file --- + if (k > 1) then + strm%k_gvd = k-1 + strm%n_gvd = strm%file(k-1)%nt + strm%found_gvd = .true. + endif + do n=1,strm%file(k)%nt + if ( strm%file(k)%date(n) < dDateL ) then + strm%k_gvd = k + strm%n_gvd = n + strm%found_gvd = .true. + endif + enddo + elseif (k == strm%nFiles) then + strm%k_gvd = k + strm%n_gvd = strm%file(k)%nt + strm%found_gvd = .true. + end if + if (strm%found_gvd) then + kf = strm%k_gvd + nf = strm%n_gvd + rDategvd = strm%file(kf)%date(nf) + strm%file(kf)%secs(nf)/spd ! GVD date + frac day + endif + end if + + !----------------------------------------------------------- + ! dateIn > rDategvd + ! limit -> abort + ! extend -> use gvd value, set UB to 99991231 + ! cycle -> lvd is UB, gvd is LB, shift mDateLB by nYears + !----------------------------------------------------------- + + if (strm%found_gvd .and. rDateIn >= rDategvd) then + if (limit) then + write(s_logunit,*) trim(subName)," ERROR: limit on and rDateIn gt rDategvd",rDateIn,rDategvd + call shr_stream_abort(trim(subName)//" ERROR: rDateIn gt rDategvd limit true") + return + endif + + if (.not.cycle) then + k_lb = strm%k_gvd + n_lb = strm%n_gvd + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_gvd + n_ub = strm%n_gvd + dDateUB = 99991231 + mDateUB = 99991231 + secUB = 0 + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb5 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + if (cycle) then + k_lb = strm%k_gvd + n_lb = strm%n_gvd + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + k_ub = strm%k_lvd + n_ub = strm%n_lvd + dDateUB = strm%file(k_ub)%date(n_ub) + call shr_cal_date2ymd(dDateUB,yy,mm,dd) + yy = yy + (mYear-dYear+nYears) + call shr_cal_ymd2date(yy,mm,dd,mDateUB) + secUB = strm%file(k_ub)%secs(n_ub) + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb6 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + + endif + + if ( rDate1 < rDateIn ) then + !--- increment lb and continue to search --- + k_lb = k + n_lb = strm%file(k)%nt + else + !--- the greatest lower-bound is in file k, find it --- + do n=1,strm%file(k)%nt + rDate2 = strm%file(k)%date(n) + strm%file(k)%secs(n)/spd ! date + frac day + if ( rDate2 <= rDateIn ) then + !--- found another/greater lower-bound --- + k_lb = k + n_lb = n + else + !--- found the least upper-bound --- + k_ub = k + n_ub = n + + dDateLB = strm%file(k_lb)%date(n_lb) + call shr_cal_date2ymd(dDateLB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateLB) + secLB = strm%file(k_lb)%secs(n_lb) + fileLB = strm%file(k_lb)%name + + dDateUB = strm%file(k_ub)%date(n_ub) + call shr_cal_date2ymd(dDateUB,yy,mm,dd) + yy = yy + (mYear-dYear) + call shr_cal_ymd2date(yy,mm,dd,mDateUB) + secUB = strm%file(k_ub)%secs(n_ub) + fileUB = strm%file(k_ub)%name +! write(s_logunit,*)'tcx fb7 ',n_lb,mDateLB,secLB,n_ub,mDateUB,secUB +! call shr_sys_flush(s_logunit) + return + endif + enddo + endif + end do C + endif + + call shr_stream_abort(trim(subName)//' ERROR: findBounds failed') + return + +end subroutine shr_stream_findBounds + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_readTCoord -- read in time coordinates with possible offset +! +! !DESCRIPTION: +! verify time coordinate data is OK +! +! !REVISION HISTORY: +! 2009-Sep-01 - T. Craig - modified +! 2005-Apr-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_readTCoord(strm,k,rc) + + use netcdf + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(inout) :: strm ! data stream to query + integer(SHR_KIND_IN) ,intent(in) :: k ! stream index + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + character(SHR_KIND_CL) :: fileName ! filename to read + integer(SHR_KIND_IN) :: nt + integer(SHR_KIND_IN) :: num,n + integer(SHR_KIND_IN) :: din,dout + integer(SHR_KIND_IN) :: sin,sout,offin + integer(SHR_KIND_IN) :: lrc + integer(SHR_KIND_IN) :: fid,vid,ndims,rcode + integer(SHR_KIND_IN),allocatable :: dids(:) + character(SHR_KIND_CS) :: units,calendar + character(SHR_KIND_CS) :: bunits ! time units (days,secs,...) + integer(SHR_KIND_IN) :: bdate ! base date: calendar date + real(SHR_KIND_R8) :: bsec ! base date: elapsed secs + integer(SHR_KIND_IN) :: ndate ! calendar date of time value + real(SHR_KIND_R8) :: nsec ! elapsed secs on calendar date + real(SHR_KIND_R8),allocatable :: tvar(:) + !----- formats ----- + character(*),parameter :: subname = '(shr_stream_readTCoord) ' + character(*),parameter :: F01 = "('(shr_stream_readTCoord) ',a,2i7)" + +!------------------------------------------------------------------------------- + + lrc = 0 + + !--- need to read in this data --- + call shr_stream_getFile(strm%filePath,strm%file(k)%name,fileName) + rCode = nf90_open(fileName,nf90_nowrite,fid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_open file '//trim(filename)) + rCode = nf90_inq_varid(fid,trim(strm%domTvarName),vid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_inq_varid') + rCode = nf90_inquire_variable(fid,vid,ndims=ndims) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_inquire_variable1') + allocate(dids(ndims)) + rCode = nf90_inquire_variable(fid,vid,dimids=dids) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_inquire_variable2') + rCode = nf90_inquire_dimension(fid,dids(1),len=nt) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_inquire_dimension') + deallocate(dids) + + allocate(strm%file(k)%date(nt),strm%file(k)%secs(nt)) + strm%file(k)%nt = nt + + units = ' ' + calendar = ' ' + rCode = nf90_get_att(fid, vid, 'units', units) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_get_att units') + rCode = nf90_inquire_attribute(fid, vid, 'calendar') + if (rCode == nf90_noerr) then + rCode = nf90_get_att(fid, vid, 'calendar', calendar) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_get_att calendar') + else + calendar = trim(shr_cal_noleap) + endif + n = len_trim(units) + if (ichar(units(n:n)) == 0 ) units(n:n) = ' ' + n = len_trim(calendar) + if (ichar(calendar(n:n)) == 0 ) calendar(n:n) = ' ' + call shr_string_leftalign(units) + call shr_string_leftalign(calendar) + call shr_string_parseCFtunit(units,bunits,bdate,bsec) + strm%calendar = trim(shr_cal_calendarName(trim(calendar))) + + allocate(tvar(nt)) + rcode = nf90_get_var(fid,vid,tvar) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_get_var') + rCode = nf90_close(fid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_close') + do n = 1,nt + call shr_cal_advDate(tvar(n),bunits,bdate,bsec,ndate,nsec,calendar) + strm%file(k)%date(n) = ndate + strm%file(k)%secs(n) = nint(nsec) + enddo + deallocate(tvar) + + if (strm%offset /= 0) then + if (size(strm%file(k)%date) /= size(strm%file(k)%secs)) then +! rc = 1 + write(s_logunit,F01) "Incompatable date and secs sizes",size(strm%file(k)%date),size(strm%file(k)%secs) + call shr_sys_abort() + endif + num = size(strm%file(k)%date) + offin = strm%offset + do n = 1,num + din = strm%file(k)%date(n) + sin = strm%file(k)%secs(n) + call shr_cal_advDateInt(offin,'seconds',din,sin,dout,sout,calendar) +! write(s_logunit,*) 'tcx debug rtc1 ',n,strm%offset,din,sin,dout,sout + strm%file(k)%date(n) = dout + strm%file(k)%secs(n) = sout + enddo + endif + + strm%file(k)%haveData = .true. + call shr_stream_verifyTCoord(strm,k,lrc) ! check new t-coord data + + if (present(rc)) then + rc = lrc + endif + +end subroutine shr_stream_readTCoord + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_verifyTCoord -- verify time coordinate data is OK +! +! !DESCRIPTION: +! verify time coordinate data is OK +! +! !REVISION HISTORY: +! 2005-Apr-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_verifyTCoord(strm,k,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + integer(SHR_KIND_IN) :: k ! index of file to check + integer(SHR_KIND_IN) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! generic loop index + integer(SHR_KIND_IN) :: nt ! size of t-dimension + integer(SHR_KIND_IN) :: date1,secs1 ! date and seconds for a time coord + integer(SHR_KIND_IN) :: date2,secs2 ! date and seconds for next time coord + logical :: checkIt ! have data / do comparison + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_verifyTCoord) ' + character(*),parameter :: F00 = "('(shr_stream_verifyTCoord) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_verifyTCoord) ',a,2i7)" + character(*),parameter :: F02 = "('(shr_stream_verifyTCoord) ',a,2i9.8)" + +!------------------------------------------------------------------------------- +! Notes: +! o checks that dates are increasing (must not decrease) +! o does not check for valid dates (eg. day=0 & month = 13 are "OK") +! o checks that secs are strictly increasing within any one day +! o checks that 0 <= secs <= spd (seconds per day) +! o checks all dates from one file plus last date of previous file and +! first date of next file +!------------------------------------------------------------------------------- + + rc = 0 + if (debug>1 .and. s_loglev > 0) write(s_logunit,F01) "checking t-coordinate data for file k =",k + + if ( .not. strm%file(k)%haveData) then + rc = 1 + write(s_logunit,F01) "Don't have data for file ",k + call shr_stream_abort(subName//"ERROR: can't check -- file not read.") + return + end if + + do n=1,strm%file(k)%nt+1 + checkIt = .false. + + !--- do we have data for two consecutive dates? --- + if (n==1) then + !--- compare with previous file? --- + if (k>1) then + if ( strm%file(k-1)%haveData ) then + nt = strm%file(k-1)%nt + date1 = strm%file(k-1)%date(nt) + secs1 = strm%file(k-1)%secs(nt) + date2 = strm%file(k )%date(n) + secs2 = strm%file(k )%secs(n) + checkIt = .true. + if (debug>1 .and. s_loglev > 0) write(s_logunit,F01) "comparing with previous file for file k =",k + end if + end if + else if (n==strm%file(k)%nt+1) then + !--- compare with next file? --- + if (k1 .and. s_loglev > 0) write(s_logunit,F01) "comparing with next file for file k =",k + end if + end if + else + !--- compare within this file --- + date1 = strm%file(k)%date(n-1) + secs1 = strm%file(k)%secs(n-1) + date2 = strm%file(k)%date(n ) + secs2 = strm%file(k)%secs(n ) + checkIt = .true. + end if + + !--- compare two consecutive dates --- + if (checkIt) then + if ( date1 > date2 ) then + rc = 1 + write(s_logunit,F01) "ERROR: calendar dates must be increasing" + write(s_logunit,F02) "date(n), date(n+1) = ",date1,date2 + call shr_stream_abort(subName//"ERROR: calendar dates must be increasing") + return + else if ( date1 == date2 ) then + if ( secs1 >= secs2 ) then + rc = 1 + write(s_logunit,F01) "ERROR: elapsed seconds on a date must be strickly increasing" + write(s_logunit,F02) "secs(n), secs(n+1) = ",secs1,secs2 + call shr_stream_abort(subName//"ERROR: elapsed seconds must be increasing") + return + end if + end if + if ( secs1 < 0 .or. spd < secs1 ) then + rc = 1 + write(s_logunit,F01) "ERROR: elapsed seconds out of valid range [0,spd]" + write(s_logunit,F02) "secs(n) = ",secs1 + call shr_stream_abort(subName//"ERROR: elapsed seconds out of range") + return + end if + end if + end do + + if (debug>0 .and. s_loglev > 0) write(s_logunit,F01) "data is OK (non-decreasing) for file k =",k + +end subroutine shr_stream_verifyTCoord + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getFileFieldList -- Get list of file fields +! +! !DESCRIPTION: +! Get list of file fields +! \newline +! call shr\_stream\_getFileFieldList(stream,list,rc) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getFileFieldList(stream,list,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: stream ! stream in question + character(*) ,intent(out) :: list ! field list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode ! return code + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_getFileFieldList) ' + character(*),parameter :: F00 = "('(shr_stream_getFileFieldList) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + rCode = 0 + + list = stream%fldListFile + + if (present(rc)) rc = rCode + +end subroutine shr_stream_getFileFieldList + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getModelFieldList -- Get list of file fields +! +! !DESCRIPTION: +! Get list of file fields +! \newline +! call shr\_stream\_getModelFieldList(stream,list,rc) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getModelFieldList(stream,list,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: stream ! stream in question + character(*) ,intent(out) :: list ! field list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode ! return code + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_getModelFieldList) ' + character(*),parameter :: F00 = "('(shr_stream_getModelFieldList) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + rCode = 0 + + list = stream%fldListModel + + if (present(rc)) rc = rCode + +end subroutine shr_stream_getModelFieldList + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getFileFieldName -- Get name of k-th field in list +! +! !DESCRIPTION: +! Get name of k-th field in list +! \newline +! call shr\_stream\_getFileFieldName(stream,k,name,rc) +! +! !REVISION HISTORY: +! 2005-May-05 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getFileFieldName(stream,k,name,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: stream ! stream in question + integer(SHR_KIND_IN) ,intent(in) :: k ! index of field + character(*) ,intent(out) :: name ! k-th name in list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode ! return code + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_getFileFieldName) ' + character(*),parameter :: F00 = "('(shr_stream_getFileFieldName) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + rCode = 0 + + call shr_string_listGetName(stream%fldListFile,k,name,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_stream_getFileFieldName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getModelFieldName -- Get name of k-th field in list +! +! !DESCRIPTION: +! Get name of k-th field in list +! \newline +! call shr\_stream\_getModelFieldName(stream,k,name,rc) +! +! !REVISION HISTORY: +! 2005-May-05 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getModelFieldName(stream,k,name,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: stream ! stream in question + integer(SHR_KIND_IN) ,intent(in) :: k ! index of field + character(*) ,intent(out) :: name ! k-th name in list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: rCode ! return code + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_getModelFieldName) ' + character(*),parameter :: F00 = "('(shr_stream_getModelFieldName) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + rCode = 0 + + call shr_string_listGetName(stream%fldListModel,k,name,rCode) + + if (present(rc)) rc = rCode + +end subroutine shr_stream_getModelFieldName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getFilePath -- return file path +! +! !DESCRIPTION: +! Returns file path. +! +! !REVISION HISTORY: +! 2005-Nov-23 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getFilepath(strm,path) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + character(*) ,intent(out) :: path ! file path + +!EOP + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + path = strm%filePath + +end subroutine shr_stream_getFilePath + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getDataSource -- return data source meta data +! +! !DESCRIPTION: +! Returns data source meta data. +! +! !REVISION HISTORY: +! 2005-Feb-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getDataSource(strm,str) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + character(*) ,intent(out) :: str ! meta data + +!EOP + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + str = strm%dataSource + +end subroutine shr_stream_getDataSource + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getCalendar -- return calendar name +! +! !DESCRIPTION: +! Returns calendar name +! +! !REVISION HISTORY: +! 2010-Oct-11 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getCalendar(strm,k,calendar) + + use netcdf + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + integer(SHR_KIND_IN) ,intent(in) :: k ! file to query + character(*) ,intent(out) :: calendar ! calendar name + +!EOP + + integer(SHR_KIND_IN) :: fid, vid, n + character(SHR_KIND_CL) :: fileName,strmfile,lcal + integer(SHR_KIND_IN) :: rCode + character(*),parameter :: subName = '(shr_stream_getCalendar) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lcal = ' ' + calendar = ' ' + if (k > strm%nfiles) call shr_sys_abort(subname//' ERROR: k gt nfiles') + strmfile = strm%file(k)%name + call shr_stream_getFile(strm%filePath,strmfile,fileName) + rCode = nf90_open(fileName,nf90_nowrite,fid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_open file '//trim(filename)) + rCode = nf90_inq_varid(fid,trim(strm%domTvarName),vid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_inq_varid') + rCode = nf90_inquire_attribute(fid, vid, 'calendar') + if (rCode == nf90_noerr) then + rCode = nf90_get_att(fid, vid, 'calendar', lcal) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_get_att calendar') + else + lcal = trim(shr_cal_noleap) + endif + n = len_trim(lcal) + if (ichar(lcal(n:n)) == 0 ) lcal(n:n) = ' ' + call shr_string_leftalign(lcal) + calendar = trim(shr_cal_calendarName(trim(lcal))) + rCode = nf90_close(fid) + if (rcode /= nf90_noerr) call shr_sys_abort(subname//' ERROR: nf90_close') + + return + +end subroutine shr_stream_getCalendar + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getDomainInfo -- return domain information +! +! !DESCRIPTION: +! Returns domain information data. +! +! !REVISION HISTORY: +! 2005-Mar-13 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getDomainInfo(strm,filePath,fileName,timeName,lonName,latName,maskName,areaName) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + character(*) ,intent(out) :: filePath ! domain file path + character(*) ,intent(out) :: fileName ! domain file name + character(*) ,intent(out) :: timeName ! domain time var name + character(*) ,intent(out) :: lonName ! domain lon var name + character(*) ,intent(out) :: latName ! domain lat var name + character(*) ,intent(out) :: maskName ! domain mask var name + character(*) ,intent(out) :: areaName ! domain area var name + +!EOP + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + filePath = strm%domFilePath + fileName = strm%domFileName + timeName = strm%domTvarName + lonName = strm%domXvarName + latName = strm%domYvarName + maskName = strm%domMaskName + areaName = strm%domAreaName + +end subroutine shr_stream_getDomainInfo + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getFile -- Acquire file, return name of file to open +! +! !DESCRIPTION: +! Acquire file (if necessary) and return name of file to open +! \newline +! call shr\_stream\_getFile(path,fileName,localFileName,rc) +! +! !REVISION HISTORY: +! 2007-Aug-24 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getFile(filePath,fileName,localFile,rc) + + use shr_file_mod, only: shr_file_queryPrefix, shr_file_noPrefix + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: filePath ! file path + character(*) ,intent(inout) :: fileName ! file name + character(*) ,optional,intent(out) :: localFile ! name of acquired file + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + character(SHR_KIND_CL) :: localFn ! name of acquired file + integer (SHR_KIND_IN) :: rCode ! return code + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_getFile) ' + character(*),parameter :: F00 = "('(shr_stream_getFile) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! - this routine reflects an added stream file handling requirement: +! for files on an nfs-mounted file system (available via unix cp), +! there are two options... +! 1) read the file without making a local copy: read path/file +! 2) copy path/file to file, and then read file +! - the shr_file_get/put file name format is used to select the option: +! using shr_file_queryPrefix -- if recognized prefix found -- do shr_file_get +! otherwise use the file in place. +! - if optional argument localFile is present +! then fileName is unaltered and localFile is the file to be read +! else fileName is altered and contains the name of the file to be read +! - this routine is somewhat awkward but reduces redundant code +!------------------------------------------------------------------------------- + + rCode = 0 + + if ( shr_file_queryPrefix(filePath) /= shr_file_noPrefix ) then + localFn = fileName + call shr_file_get(rCode,localFn, trim(filePath)//fileName) + else ! don't copy file, read original file + localFn = trim(filePath)//fileName + end if + + if (debug>0 .and. s_loglev > 0) then + write(s_logunit,F00) "DEBUG: remote file : ",trim(filePath)//trim(fileName) + write(s_logunit,F00) "DEBUG: local file : ",trim(localFn) + end if + + if (.not. present(localFile)) fileName = localFn ! clobber input fileName + if ( present(localFile)) localFile = localFn ! don't clobber fileName + + if (present(rc)) rc = rCode + +end subroutine shr_stream_getFile + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getFirstFileName -- returns first file name +! +! !DESCRIPTION: +! Returns first file name in stream. +! +! !REVISION HISTORY: +! 2005-Feb-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getFirstFileName(strm,file,path) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + character(*) ,intent(out) :: file ! file name + character(*),optional ,intent(out) :: path ! file path + +!EOP + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (present(path)) path = strm%filePath + file = strm%file(1)%name + +end subroutine shr_stream_getFirstFileName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getNextFileName -- returns next file name in sequence +! +! !DESCRIPTION: +! Returns next file name in sequence +! +! !REVISION HISTORY: +! 2005-Nov-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_stream_getNextFileName(strm,fn,fnNext,path,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + character(*) ,intent(in) :: fn ! file name + character(*) ,intent(out) :: fnNext ! next file name + character(*),optional ,intent(out) :: path ! file path + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !--- local --- + integer (SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: n ! loop index + logical :: found ! file name found? + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_getNextFileName) ' + character(*),parameter :: F00 = "('(shr_stream_getNextFileName) ',8a)" + +!------------------------------------------------------------------------------- +! Note: will wrap-around data loop if lvd & gvd are known +! otherwise may return file name = "unknown" +!------------------------------------------------------------------------------- + + rCode = 0 + if (present(path)) path = strm%filePath + + !--- locate input file in the stream's list of files --- + found = .false. + do n = 1,strm%nFiles + if ( trim(fn) == trim(strm%file(n)%name)) then + found = .true. + exit + end if + end do + if (.not. found) then + rCode = 1 + write(s_logunit,F00) "ERROR: input file name is not in stream: ",trim(fn) + call shr_stream_abort(subName//"ERROR: file name not in stream: "//trim(fn)) + end if + + !--- get next file name --- + n = n+1 ! next in list + if (strm%found_lvd .and. strm%found_gvd) then + if (n > strm%k_gvd) n = strm%k_lvd ! wrap-around to lvd + else if (strm%found_lvd ) then + if (n > strm%nFiles) n = strm%k_lvd ! wrap-around to lvd + else if (n > strm%nFiles ) then + n = 1 ! wrap-around to 1st file + end if + + fnNext = trim(strm%file(n)%name) + if ( present(rc) ) rc = rCode + +end subroutine shr_stream_getNextFileName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getPrevFileName -- returns previous file name in sequence +! +! !DESCRIPTION: +! Returns previous file name in sequence +! +! !REVISION HISTORY: +! 2005-Nov-18 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + + subroutine shr_stream_getPrevFileName(strm,fn,fnPrev,path,rc) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: strm ! data stream + character(*) ,intent(in) :: fn ! file name + character(*) ,intent(out) :: fnPrev ! preciding file name + character(*),optional ,intent(out) :: path ! file path + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !--- local --- + integer (SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: n ! loop index + logical :: found ! file name found? + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_getPrevFileName) ' + character(*),parameter :: F00 = "('(shr_stream_getPrevFileName) ',8a)" + +!------------------------------------------------------------------------------- +! Note: will wrap-around data loop if lvd & gvd are known +! otherwise may return file name = "unknown" +!------------------------------------------------------------------------------- + + rCode = 0 + if (present(path)) path = strm%filePath + + !--- locate input file in the stream's list of files --- + found = .false. + do n = 1,strm%nFiles + if ( trim(fn) == trim(strm%file(n)%name)) then + found = .true. + exit + end if + end do + if (.not. found) then + rCode = 1 + write(s_logunit,F00) "ERROR: input file name is not in stream: ",trim(fn) + call shr_stream_abort(subName//"ERROR: file name not in stream: "//trim(fn)) + end if + + !--- get previous file name --- + n = n-1 ! previous in list + if (strm%found_lvd .and. strm%found_gvd) then + if ( n < strm%k_lvd) n = strm%k_gvd ! do wrap-around --- + end if + if (n>0) then + fnPrev = trim(strm%file(n)%name) + else + fnPrev = "unknown " + end if + if ( present(rc) ) rc = rCode + +end subroutine shr_stream_getPrevFileName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getNFiles -- returns number of input files in stream +! +! !DESCRIPTION: +! Returns number of input files in stream +! +! !REVISION HISTORY: +! 2010-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getNFiles(strm,nfiles) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + integer(SHR_KIND_IN) ,intent(out) :: nfiles ! number of input files in stream + +!EOP + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + nfiles = strm%nfiles + +end subroutine shr_stream_getNFiles + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_restWrite -- write stream data to a restart file +! +! !DESCRIPTION: +! Write stream data to a restart file. +! +! !REVISION HISTORY: +! 2005-Nov-21 -- B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_restWrite(strm,fileName,caseName,caseDesc,nstrms,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(in) :: strm(:) ! vector of data streams + character(*) ,intent(in) :: fileName ! name of restart file + character(*) ,intent(in) :: caseName ! case name + character(*) ,intent(in) :: caseDesc ! case description + integer(SHR_KIND_IN),optional,intent(in) :: nstrms ! number of streams + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !--- local --- + integer (SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: nStreams ! number of streams + integer(SHR_KIND_IN) :: k,n ! generic loop index + character( 8) :: dStr ! F90 wall clock date str yyyymmdd + character(10) :: tStr ! F90 wall clock time str hhmmss.sss + character(SHR_KIND_CS) :: str ! generic text string + integer(SHR_KIND_IN) :: nUnit ! a file unit number + integer(SHR_KIND_IN) :: nt ! number of time samples + character(SHR_KIND_CS) :: tInterpAlgo ! for backwards compatability + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_restWrite) ' + character(*),parameter :: F00 = "('(shr_stream_restWrite) ',16a) " + character(*),parameter :: F01 = "('(shr_stream_restWrite) ',a,i5,a,5a) " + character(*),parameter :: F02 = "('(shr_stream_restWrite) ',a,i5,a,5i8) " + character(*),parameter :: F03 = "('(shr_stream_restWrite) ',a,i5,a,5l3) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + rCode = 0 + tInterpAlgo = 'unused' + + if (present(nstrms)) then + if (size(strm) < nstrms) then + write(s_logunit,F02) "ERROR: nstrms too large for strm",size(strm),nstrms + call shr_stream_abort(subname//": ERROR: nstrms too large for strm") + endif + nStreams = nstrms + else + nStreams = size(strm) + endif + call date_and_time(dStr,tStr) + + !--- log info to stdout --- + if (s_loglev > 0) then + write(s_logunit,F00) "case name : ",trim(caseName) + write(s_logunit,F00) "case description : ",trim(caseDesc) + write(s_logunit,F00) "File created : ",dStr(1:4)//'-'//dStr(5:6)//'-'//dStr(7:8)//' ' & + & //tStr(1:2)//':'//tStr(3:4)//':'//tStr(5:6) + write(s_logunit,F01) "Number of streams ",nStreams + endif + + !---------------------------------------------------------------------------- + ! write the data + !---------------------------------------------------------------------------- + + nUnit = shr_file_getUnit() ! get an unused unit number + open(nUnit,file=trim(fileName),form="unformatted",action="write") + + str = "case name : "//caseName + write(nUnit) str + str = "case description : "//caseDesc + write(nUnit) str + str = 'File created : '//dStr(1:4)//'-'//dStr(5:6)//'-'//dStr(7:8)//' ' & + & //tStr(1:2)//':'//tStr(3:4)//':'//tStr(5:6) + write(nUnit) str + + write(nUnit) nStreams + do k = 1,nStreams + if (.not. shr_stream_isInit(strm(k))) then ! has stream been initialized? + rCode = 1 + write(s_logunit,F01) "ERROR: can't write uninitialized stream to a restart file, k = ",k + call shr_stream_abort(subName//": ERROR: given uninitialized stream") + end if + + write(nUnit) strm(k)%init ! has stream been initialized? + write(nUnit) strm(k)%nFiles ! number of data files + write(nUnit) strm(k)%dataSource ! meta data identifying data source + write(nUnit) strm(k)%filePath ! remote location of files + + if (s_loglev > 0) write(s_logunit,F01) "* stream ",k," first file name = ",trim(strm(k)%file(1)%name) + if (s_loglev > 0) write(s_logunit,F03) "* stream ",k," first have data = ",strm(k)%file(1)%haveData + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," first nt = ",strm(k)%file(1)%nt + nt = strm(k)%file(1)%nt + if (strm(k)%file(1)%haveData) then + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," first date secs = ", & + strm(k)%file(1)%date(1),strm(k)%file(1)%secs(1) + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," last date secs = ", & + strm(k)%file(1)%date(nt),strm(k)%file(1)%secs(nt) + endif + do n=1,strm(k)%nFiles ! data specific to each file... + write(nUnit) strm(k)%file(n)%name ! the file name + write(nUnit) strm(k)%file(n)%haveData ! has t-coord data been read in? + write(nUnit) strm(k)%file(n)%nt ! size of time dimension + if (strm(k)%file(n)%haveData) then ! ie. if arrays have been allocated + write(nUnit) strm(k)%file(n)%date(:) ! t-coord date: yyyymmdd + write(nUnit) strm(k)%file(n)%secs(:) ! t-coord secs: elapsed on date + end if + end do + + write(nUnit) strm(k)%yearFirst ! first year to use in t-axis (yyyymmdd) + write(nUnit) strm(k)%yearLast ! last year to use in t-axis (yyyymmdd) + write(nUnit) strm(k)%yearAlign ! align yearFirst with this model year + write(nUnit) strm(k)%offset ! time axis offset +! write(nUnit) strm(k)%taxMode ! time axis cycling mode + + write(nUnit) strm(k)%k_lvd ! file of least valid date + write(nUnit) strm(k)%n_lvd ! sample of least valid date + write(nUnit) strm(k)%found_lvd ! T <=> k_lvd,n_lvd have been set + write(nUnit) strm(k)%k_gvd ! file of greatest valid date + write(nUnit) strm(k)%n_gvd ! sample of greatest valid date + write(nUnit) strm(k)%found_gvd ! T <=> k_gvd,n_gvd have been set + + write(nUnit) strm(k)%fldListFile ! field list: file's field names + write(nUnit) strm(k)%fldListModel ! field list: model's field names + write(nUnit) tInterpAlgo ! unused + write(nUnit) strm(k)%domFileName ! domain file: name + write(nUnit) strm(k)%domFilePath ! domain file: path + write(nUnit) strm(k)%domTvarName ! domain file: time-dim var name + write(nUnit) strm(k)%domXvarName ! domain file: x-dim var name + write(nUnit) strm(k)%domYvarName ! domain file: y-dim var ame + write(nUnit) strm(k)%domAreaName ! domain file: area var name + write(nUnit) strm(k)%domMaskName ! domain file: mask var name + + end do + + close(nUnit) + call shr_file_freeUnit(nUnit) + if ( present(rc) ) rc = rCode + +end subroutine shr_stream_restWrite + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_restRead -- read stream data from a restart file +! +! !DESCRIPTION: +! Read stream data to a restart file. +! Either shr_stream_init xor shr_stream_restRead must be called +! Do not call both routines. +! +! !REVISION HISTORY: +! 2005-Nov-21 -- B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_restRead(strm,fileName,nstrms,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType) ,intent(inout) :: strm(:) ! vector of data streams + character(*) ,intent(in) :: fileName ! name of restart file + integer(SHR_KIND_IN),optional,intent(in) :: nstrms ! number of streams in strm + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !--- local --- + integer (SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: nStreams ! number of streams + integer(SHR_KIND_IN) :: k,n ! generic loop index + character(SHR_KIND_CS) :: str ! generic text string + integer(SHR_KIND_IN) :: nUnit ! a file unit number + integer(SHR_KIND_IN) :: inpi ! input integer + real(SHR_KIND_R8) :: inpr ! input real + character(SHR_KIND_CXX):: inpcx ! input char + character(SHR_KIND_CL) :: inpcl ! input char + character(SHR_KIND_CS) :: inpcs ! input char + integer(SHR_KIND_IN) :: nt ! size of time dimension + character(SHR_KIND_CS) :: tInterpAlgo ! for backwards compatability + character(SHR_KIND_CL) :: name ! local variables + integer(SHR_KIND_IN) :: nFiles ! local variables + integer(SHR_KIND_IN) :: k_lvd, n_lvd, k_gvd, n_gvd ! local variables + logical :: found_lvd, found_gvd, haveData ! local variables + integer(SHR_KIND_IN),pointer :: date(:),secs(:) ! local variables + logical :: abort ! abort the restart read + logical :: readok ! read of restarts ok + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_restRead) ' + character(*),parameter :: F00 = "('(shr_stream_restRead) ',16a) " + character(*),parameter :: F01 = "('(shr_stream_restRead) ',a,i5,a,5a) " + character(*),parameter :: F02 = "('(shr_stream_restRead) ',a,i5,a,5i8) " + character(*),parameter :: F03 = "('(shr_stream_restRead) ',a,i5,a,5l3) " + character(*),parameter :: F04 = "('(shr_stream_restRead) ',a,4i8) " + character(*),parameter :: F05 = "('(shr_stream_restRead) ',a,2i8,6a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + rCode = 0 + tInterpAlgo = 'unused' + abort = .false. + inpcl = ' ' + + !---------------------------------------------------------------------------- + ! read the data + !---------------------------------------------------------------------------- + + nUnit = shr_file_getUnit() ! get an unused unit number + open(nUnit,file=trim(fileName),form="unformatted",status="old",action="read", iostat=rCode) + if ( rCode /= 0 )then + call shr_file_freeUnit(nUnit) + call shr_stream_abort(subName//": ERROR: error opening file: "//trim(fileName) ) + if ( present(rc) ) rc = rCode + return + end if + + read(nUnit) str ! case name + if (s_loglev > 0) write(s_logunit,F00) trim(str) + read(nUnit) str ! case description + if (s_loglev > 0) write(s_logunit,F00) trim(str) + read(nUnit) str ! file creation date + if (s_loglev > 0) write(s_logunit,F00) trim(str) + + read(nUnit) nStreams + if (present(nstrms)) then + if (nstrms /= nStreams) then + write(s_logunit,F02) "ERROR: nstrms ne nStreams on restart",nstrms,' ',nStreams + call shr_stream_abort(subname//": ERROR: nstrms ne nStreams on restart") + endif + nStreams = nstrms + endif + if (s_loglev > 0) write(s_logunit,F01) "Number of streams ",nStreams + + do k = 1,nStreams + read(nUnit) strm(k)%init ! has stream been initialized? + if (.not. strm(k)%init) then + rCode = 1 + write(s_logunit,F01) "ERROR: uninitialized stream in restart file, k = ",k + call shr_stream_abort(subName//": ERROR: reading uninitialized stream") + end if + call shr_stream_setInit(strm(k)) + + readok = .true. + + ! tcraig, don't overwrite these from input + read(nUnit) nFiles ! number of data files + read(nUnit) inpcs ! dataSource ! meta data identifying data source + read(nUnit) inpcl ! filePath ! remote location of files + + do n=1,nFiles ! data specific to each file... + read(nUnit) name ! the file name + read(nUnit) haveData ! has t-coord data been read in? + read(nUnit) nt ! size of time dimension + + if (haveData) then ! ie. if arrays have been allocated + allocate(date(nt)) + allocate(secs(nt)) + read(nUnit) date(:) ! t-coord date: yyyymmdd + read(nUnit) secs(:) ! t-coord secs: elapsed on date + if (strm(k)%nFiles >= n) then + if (trim(name) == trim(strm(k)%file(n)%name)) then + write(s_logunit,F05) "reading time axis for stream restart filename ",k,n, & + ' ',trim(name),' ',trim(strm(k)%file(n)%name) + strm(k)%file(n)%nt = nt + strm(k)%file(n)%haveData = haveData + allocate(strm(k)%file(n)%date(nt)) + allocate(strm(k)%file(n)%secs(nt)) + strm(k)%file(n)%date(1:nt) = date(1:nt) + strm(k)%file(n)%secs(1:nt) = secs(1:nt) + else + write(s_logunit,F05) "WARNING, skip time axis for stream restart filename ",k,n,& + ' ',trim(name),' ',trim(strm(k)%file(n)%name) + readok = .false. + endif ! filenames consistent + endif ! strm nfiles + deallocate(date) + deallocate(secs) + end if + end do + + if (s_loglev > 0) write(s_logunit,F01) "* stream ",k," first file name = ",trim(strm(k)%file(1)%name) + if (s_loglev > 0) write(s_logunit,F03) "* stream ",k," first have data = ",strm(k)%file(1)%haveData + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," first nt = ",strm(k)%file(1)%nt + if (strm(k)%file(1)%haveData) then + nt = strm(k)%file(1)%nt + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," first date secs = ", & + strm(k)%file(1)%date(1),strm(k)%file(1)%secs(1) + if (s_loglev > 0) write(s_logunit,F02) "* stream ",k," last date secs = ", & + strm(k)%file(1)%date(nt),strm(k)%file(1)%secs(nt) + endif + +! tcraig, apr 2 2012, offset is the only field that should not change here for time axis +! read(nUnit) strm(k)%yearFirst ! last year to use in t-axis (yyyymmdd) +! read(nUnit) strm(k)%yearLast ! last year to use in t-axis (yyyymmdd) +! read(nUnit) strm(k)%yearAlign ! align yearFirst with this model year +! read(nUnit) strm(k)%offset ! time axis offset + read(nUnit) inpi ! first year to use in t-axis (yyyymmdd) +! if (inpi /= strm(k)%yearFirst) then +! write(s_logunit,F04) " ERROR: yearFirst disagrees ",k,strm(k)%yearFirst,inpi +! abort=.true. +! endif + read(nUnit) inpi ! last year to use in t-axis (yyyymmdd) +! if (inpi /= strm(k)%yearLast) then +! write(s_logunit,F04) " ERROR: yearLast disagrees ",k,strm(k)%yearLast,inpi +! abort=.true. +! endif + read(nUnit) inpi ! align year to use in t-axis (yyyymmdd) +! if (inpi /= strm(k)%yearAlign) then +! write(s_logunit,F04) " ERROR: yearAlign disagrees ",k,strm(k)%yearAlign,inpi +! abort=.true. +! endif + read(nUnit) inpi ! time axis offset + if (inpi /= strm(k)%offset) then + write(s_logunit,F04) " ERROR: offset disagrees ",k,strm(k)%offset,inpi + abort=.true. + endif + +! read(nUnit) strm(k)%taxMode ! time axis cycling mode + + read(nUnit) k_lvd ! file of least valid date + read(nUnit) n_lvd ! sample of least valid date + read(nUnit) found_lvd ! T <=> k_lvd,n_lvd have been set + read(nUnit) k_gvd ! file of greatest valid date + read(nUnit) n_gvd ! sample of greatest valid date + read(nUnit) found_gvd ! T <=> k_gvd,n_gvd have been set + ! tcraig, april 2012, only overwrite if restart read is ok + if (readok) then + write(s_logunit,F05) "setting k n and found lvd gvd on restart ",k,n,' ',trim(name) + strm(k)%k_lvd = k_lvd + strm(k)%n_lvd = n_lvd + strm(k)%found_lvd = found_lvd + strm(k)%k_gvd = k_gvd + strm(k)%n_gvd = n_gvd + strm(k)%found_gvd = found_gvd + endif + + ! tcraig, april 2012, don't overwrite these from input + read(nUnit) inpcx ! fldListFile ! field list: file's field names + read(nUnit) inpcx ! fldListModel ! field list: model's field names + read(nUnit) inpcs ! tInterpAlgo ! unused + read(nUnit) inpcl ! domFileName ! domain file: name + read(nUnit) inpcl ! domFilePath ! domain file: path + read(nUnit) inpcs ! domTvarName ! domain file: time-dim var name + read(nUnit) inpcs ! domXvarName ! domain file: x-dim var name + read(nUnit) inpcs ! domYvarName ! domain file: y-dim var ame + read(nUnit) inpcs ! domAreaName ! domain file: area var name + read(nUnit) inpcs ! domMaskName ! domain file: mask var name + + end do + + if (abort) then + write(s_logunit,F00) "ERRORS Detected ABORTING NOW" + call shr_stream_abort(subName//": ERRORS Detected ABORTING NOW") + endif + + close(nUnit) + call shr_file_freeUnit(nUnit) + if ( present(rc) ) rc = rCode + +end subroutine shr_stream_restRead + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_dataDump -- dump all data to stdout for debugging +! +! !DESCRIPTION: +! Dump all data to stdout for debugging +! +! !REVISION HISTORY: +! 2005-Mar-23 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_dataDump(strm) + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType),intent(in) :: strm ! data stream + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: k ! generic loop index + + !----- formats ----- + character(*),parameter :: subName = '(shr_stream_dataDump) ' + character(*),parameter :: F00 = "('(shr_stream_dataDump) ',8a)" + character(*),parameter :: F01 = "('(shr_stream_dataDump) ',a,3i5)" + character(*),parameter :: F02 = "('(shr_stream_dataDump) ',a,365i9.8)" + character(*),parameter :: F03 = "('(shr_stream_dataDump) ',a,365i6)" + +!------------------------------------------------------------------------------- +! notes: +!------------------------------------------------------------------------------- + + if (s_loglev <= 0) return + + write(s_logunit,F00) "dump internal data for debugging..." + + !----------------------------------------------------------------------------- + ! dump internal data + !----------------------------------------------------------------------------- + write(s_logunit,F01) "nFiles = ", strm%nFiles + write(s_logunit,F00) "filePath = ", trim(strm%filePath) + do k=1,strm%nFiles + write(s_logunit,F01) "data for file k = ",k + write(s_logunit,F00) "* file(k)%name = ", trim(strm%file(k)%name) + if ( strm%file(k)%haveData ) then + write(s_logunit,F01) "* file(k)%nt = ", strm%file(k)%nt + write(s_logunit,F02) "* file(k)%date(:) = ", strm%file(k)%date(:) + write(s_logunit,F03) "* file(k)%Secs(:) = ", strm%file(k)%secs(:) + else + write(s_logunit,F00) "* time coord data not read in yet for this file" + end if + end do + write(s_logunit,F01) "yearF/L/A = ", strm%yearFirst,strm%yearLast,strm%yearAlign + write(s_logunit,F01) "offset = ", strm%offset + write(s_logunit,F00) "taxMode = ", trim(strm%taxMode) + + write(s_logunit,F00) "fldListFile = ", trim(strm%fldListFile) + write(s_logunit,F00) "fldListModel = ", trim(strm%fldListModel) + write(s_logunit,F00) "domFileName = ", trim(strm%domFileName) + write(s_logunit,F00) "domFilePath = ", trim(strm%domFilePath) + write(s_logunit,F00) "domTvarName = ", trim(strm%domTvarName) + write(s_logunit,F00) "domXvarName = ", trim(strm%domXvarName) + write(s_logunit,F00) "domYvarName = ", trim(strm%domYvarName) + write(s_logunit,F00) "domAreaName = ", trim(strm%domAreaName) + write(s_logunit,F00) "domMaskName = ", trim(strm%domMaskName) + +end subroutine shr_stream_dataDump + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_setDebug -- Set local debug level +! +! !DESCRIPTION: +! Set local/internal debug level, 0 = production +! \newline +! General Usage: call shr\_stream\_setDebug(2) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_setDebug(level) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(in) :: level + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_setDebug) ' + character(*),parameter :: F00 = "('(shr_stream_setDebug) ',a) " + character(*),parameter :: F01 = "('(shr_stream_setDebug) ',a,i4) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + debug = level + if (s_loglev > 0) write(s_logunit,F01) "debug level reset to ",level + +end subroutine shr_stream_setDebug + +!============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_getDebug -- return local/internal debug level +! +! !DESCRIPTION: +! Return internal debug level, 0 = production +! \newline +! General Usage: call shr\_stream\_getDebug(level) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_getDebug(level) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(out) :: level + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_getDebug) ' + character(*),parameter :: F00 = "('(shr_stream_getDebug) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + level = debug + +end subroutine shr_stream_getDebug + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_setAbort -- Set abort level +! +! !DESCRIPTION: +! Set local/internal abort level, .true. = production +! \newline +! General Usage: call shr\_stream\_setAbort(.false.) +! +! !REVISION HISTORY: +! 2008-May-28 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_setAbort(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + +!EOP + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_setAbort) ' + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + doabort = flag + +end subroutine shr_stream_setAbort + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_abort -- Call abort and end +! +! !DESCRIPTION: +! Local interface for shr_stream abort calls +! General Usage: call shr\_stream\_abort(msg) +! +! !REVISION HISTORY: +! 2008-May-28 - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_abort( msg ) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + character(len=*), optional, intent(IN) :: msg ! Message to describe error + +!EOP + + character(SHR_KIND_CL) :: lmsg + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_abort) ' + character(*),parameter :: F00 = "('(shr_stream_abort) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lmsg = ' ' + if (present(msg)) lmsg= msg + + if (doabort) then + call shr_sys_abort(lmsg) + else + write(s_logunit,F00) trim(lmsg) + endif + +end subroutine shr_stream_abort + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_isInit - checks if stream is initialized +! +! !DESCRIPTION: +! Checks if stream is initialized +! +! !REVISION HISTORY: +! 2010-Oct-22 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +logical function shr_stream_isInit(strm,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType), intent(in) :: strm + integer(SHR_KIND_IN),optional,intent(out) :: rc + +!EOP + + !--- local --- + character(*),parameter :: subName = "(shr_stream_isInit)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + shr_stream_isInit = .false. + if (size(strm%initarr) == initarr_size) then + shr_stream_isInit = .true. + endif + + if (present(rc)) rc = 0 + +end function shr_stream_isInit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_setInit - Sets stream init flag to TRUE +! +! !DESCRIPTION: +! Checks if stream is initialized +! +! !REVISION HISTORY: +! 2010-Oct-22 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_stream_setInit(strm,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType), intent(inout) :: strm + integer(SHR_KIND_IN),optional,intent(out) :: rc + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: ier + character(*),parameter :: subName = "(shr_stream_setInit)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + strm%init = .true. + deallocate(strm%initarr,stat=ier) + allocate(strm%initarr(initarr_size)) + + if (present(rc)) rc = 0 + +end subroutine shr_stream_setInit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_clearInit - Sets stream init flag to TRUE +! +! !DESCRIPTION: +! Checks if stream is initialized +! +! !REVISION HISTORY: +! 2010-Oct-22 - T. Craig - initial version +! +! !INTERFACE: ----------------------------------------------------------------- + +subroutine shr_stream_clearInit(strm,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType), intent(inout) :: strm + integer(SHR_KIND_IN),optional,intent(out) :: rc + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: ier + character(*),parameter :: subName = "(shr_stream_clearInit)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + strm%init = .true. + deallocate(strm%initarr,stat=ier) + allocate(strm%initarr(initarr_size + 5)) + + if (present(rc)) rc = 0 + +end subroutine shr_stream_clearInit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_stream_bcast -- bcast stream +! +! !DESCRIPTION: +! Return internal debug level, 0 = production +! \newline +! General Usage: call shr\_stream\_bcast(level) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_stream_bcast(stream,comm,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + type(shr_stream_streamType), intent(inout) :: stream + integer(SHR_KIND_IN), intent(in) :: comm + integer(SHR_KIND_IN),optional,intent(out) :: rc + +!EOP + + !--- locals --- + integer :: n,nt + integer :: pid + + !--- formats --- + character(*),parameter :: subName = '(shr_stream_bcast) ' + character(*),parameter :: F00 = "('(shr_stream_bcast) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if ( present(rc) ) rc = 0 + call shr_mpi_commRank(comm,pid,subName) + + call shr_mpi_bcast(stream%init ,comm,subName) + call shr_mpi_bcast(stream%nFiles ,comm,subName) + call shr_mpi_bcast(stream%dataSource ,comm,subName) + call shr_mpi_bcast(stream%filePath ,comm,subName) + call shr_mpi_bcast(stream%yearFirst ,comm,subName) + call shr_mpi_bcast(stream%yearLast ,comm,subName) + call shr_mpi_bcast(stream%yearAlign ,comm,subName) + call shr_mpi_bcast(stream%offset ,comm,subName) + call shr_mpi_bcast(stream%taxMode ,comm,subName) + call shr_mpi_bcast(stream%k_lvd ,comm,subName) + call shr_mpi_bcast(stream%n_lvd ,comm,subName) + call shr_mpi_bcast(stream%found_lvd ,comm,subName) + call shr_mpi_bcast(stream%k_gvd ,comm,subName) + call shr_mpi_bcast(stream%n_gvd ,comm,subName) + call shr_mpi_bcast(stream%found_gvd ,comm,subName) + call shr_mpi_bcast(stream%fldListFile ,comm,subName) + call shr_mpi_bcast(stream%fldListModel,comm,subName) + call shr_mpi_bcast(stream%domFileName ,comm,subName) + call shr_mpi_bcast(stream%domFilePath ,comm,subName) + call shr_mpi_bcast(stream%domTvarName ,comm,subName) + call shr_mpi_bcast(stream%domXvarName ,comm,subName) + call shr_mpi_bcast(stream%domYvarName ,comm,subName) + call shr_mpi_bcast(stream%domMaskName ,comm,subName) + call shr_mpi_bcast(stream%calendar ,comm,subName) + + if (pid /= 0) allocate(stream%file(stream%nFiles)) + + do n = 1,stream%nFiles + call shr_mpi_bcast(stream%file(n)%name ,comm,subName) + call shr_mpi_bcast(stream%file(n)%haveData,comm,subName) + call shr_mpi_bcast(stream%file(n)%nt ,comm,subName) + nt = stream%file(n)%nt + if (pid /= 0) allocate(stream%file(n)%date(nt),stream%file(n)%secs(nt)) + call shr_mpi_bcast(stream%file(n)%date ,comm,subName) + call shr_mpi_bcast(stream%file(n)%secs ,comm,subName) + enddo + +end subroutine shr_stream_bcast + +!=============================================================================== +end module shr_stream_mod +!=============================================================================== + diff --git a/share/csm_share/shr/shr_string_mod.F90 b/share/csm_share/shr/shr_string_mod.F90 new file mode 100644 index 000000000000..91bee69f4641 --- /dev/null +++ b/share/csm_share/shr/shr_string_mod.F90 @@ -0,0 +1,1944 @@ +!=============================================================================== +! SVN $Id: shr_string_mod.F90 62094 2014-07-23 15:43:17Z muszala $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_string_mod.F90 $ +!=============================================================================== +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_string_mod -- string and list methods +! +! !DESCRIPTION: +! General string and specific list method. A list is a single string +! that is delimited by a character forming multiple fields, ie, +! character(len=*) :: mylist = "t:s:u1:v1:u2:v2:taux:tauy" +! The delimiter is called listDel in this module, is default ":", +! but can be set by a call to shr_string_listSetDel. +! +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_string_mod + +! !USES: +#include "shr_assert.h" + use shr_kind_mod ! F90 kinds + use shr_sys_mod ! shared system calls + use shr_timer_mod, only : shr_timer_get, shr_timer_start, shr_timer_stop + use shr_log_mod, only : errMsg => shr_log_errMsg + use shr_log_mod, only : s_loglev => shr_log_Level + use shr_log_mod, only : s_logunit => shr_log_Unit + + implicit none + private + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_string_countChar ! Count number of char in string, fn + public :: shr_string_toUpper ! Convert string to upper-case + public :: shr_string_toLower ! Convert string to lower-case + public :: shr_string_getParentDir ! For a pathname get the parent directory name + public :: shr_string_lastIndex ! Index of last substr in str + public :: shr_string_endIndex ! Index of end of substr in str + public :: shr_string_leftAlign ! remove leading white space + public :: shr_string_alphanum ! remove all non alpha-numeric characters + public :: shr_string_betweenTags ! get the substring between the two tags + public :: shr_string_parseCFtunit ! parse CF time units + public :: shr_string_clean ! Set string to all white space + + public :: shr_string_listIsValid ! test for a valid "list" + public :: shr_string_listGetNum ! Get number of fields in list, fn + public :: shr_string_listGetIndex ! Get index of field + public :: shr_string_listGetIndexF ! function version of listGetIndex + public :: shr_string_listGetName ! get k-th field name + public :: shr_string_listIntersect ! get intersection of two field lists + public :: shr_string_listUnion ! get union of two field lists + public :: shr_string_listDiff ! get set difference of two field lists + public :: shr_string_listMerge ! merge two lists to form third + public :: shr_string_listAppend ! append list at end of another + public :: shr_string_listPrepend ! prepend list in front of another + public :: shr_string_listSetDel ! Set field delimiter in lists + public :: shr_string_listGetDel ! Get field delimiter in lists + public :: shr_string_listCreateField ! return colon delimited field list + ! given number of fields N and a base string + public :: shr_string_listAddSuffix ! add a suffix to every field in a field list + public :: shr_string_setAbort ! set local abort flag + public :: shr_string_setDebug ! set local debug flag + +! !PUBLIC DATA MEMBERS: + + ! no public data members + +!EOP + + character(len=1) ,save :: listDel = ":" ! note single exec implications + character(len=2) ,save :: listDel2 = "::" ! note single exec implications + logical ,save :: doabort = .true. + integer(SHR_KIND_IN),save :: debug = 0 + +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_countChar -- Count number of occurances of a character +! +! !DESCRIPTION: +! count number of occurances of a single character in a string +! \newline +! n = shr\_string\_countChar(string,character) +! +! !REVISION HISTORY: +! 2005-Feb-28 - First version from dshr_bundle +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function shr_string_countChar(str,char,rc) + + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: str ! string to search + character(1) ,intent(in) :: char ! char to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: count ! counts occurances of char + integer(SHR_KIND_IN) :: n ! generic index + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_countChar) " + character(*),parameter :: F00 = "('(shr_string_countChar) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + count = 0 + do n = 1, len_trim(str) + if (str(n:n) == char) count = count + 1 + end do + shr_string_countChar = count + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_countChar + +!=============================================================================== +!BOP =========================================================================== +! !IROUTINE: shr_string_toUpper -- Convert string to upper case +! +! !DESCRIPTION: +! Convert the input string to upper-case. +! Use achar and iachar intrinsics to ensure use of ascii collating sequence. +! +! !REVISION HISTORY: +! 2005-Dec-20 - Move CAM version over to shared code. +! +! !INTERFACE: ------------------------------------------------------------------ + +function shr_string_toUpper(str) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to upper case + character(len=len(str)) :: shr_string_toUpper + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: aseq ! ascii collating sequence + integer(SHR_KIND_IN) :: LowerToUpper ! integer to convert case + character(len=1) :: ctmp ! Character temporary + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_toUpper) " + character(*),parameter :: F00 = "('(shr_string_toUpper) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + LowerToUpper = iachar("A") - iachar("a") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("a") .and. aseq <= iachar("z") ) & + ctmp = achar(aseq + LowertoUpper) + shr_string_toUpper(i:i) = ctmp + end do + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_toUpper + +!=============================================================================== +!BOP =========================================================================== +! !IROUTINE: shr_string_toLower -- Convert string to lower case +! +! !DESCRIPTION: +! Convert the input string to lower-case. +! Use achar and iachar intrinsics to ensure use of ascii collating sequence. +! +! !REVISION HISTORY: +! 2006-Apr-20 - Creation +! +! !INTERFACE: ------------------------------------------------------------------ +function shr_string_toLower(str) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: shr_string_toLower + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: aseq ! ascii collating sequence + integer(SHR_KIND_IN) :: UpperToLower ! integer to convert case + character(len=1) :: ctmp ! Character temporary + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_toLower) " + character(*),parameter :: F00 = "('(shr_string_toLower) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + UpperToLower = iachar("a") - iachar("A") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & + ctmp = achar(aseq + UpperToLower) + shr_string_toLower(i:i) = ctmp + end do + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_toLower + +!=============================================================================== +!BOP =========================================================================== +! !IROUTINE: shr_string_getParentDir -- For pathname get the parent directory name +! +! !DESCRIPTION: +! Get the parent directory name for a pathname. +! +! !REVISION HISTORY: +! 2006-May-09 - Creation +! +! !INTERFACE: ------------------------------------------------------------------ + +function shr_string_getParentDir(str) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: shr_string_getParentDir + + !----- local ----- + integer(SHR_KIND_IN) :: i ! Index + integer(SHR_KIND_IN) :: nlen ! Length of string + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_getParentDir) " + character(*),parameter :: F00 = "('(shr_string_getParentDir) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + nlen = len_trim(str) + if ( str(nlen:nlen) == "/" ) nlen = nlen - 1 + i = index( str(1:nlen), "/", back=.true. ) + if ( i == 0 )then + shr_string_getParentDir = str + else + shr_string_getParentDir = str(1:i-1) + end if + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_getParentDir + +!=============================================================================== +!BOP =========================================================================== +! +! +! !IROUTINE: shr_string_lastIndex -- Get index of last substr within string +! +! !DESCRIPTION: +! Get index of last substr within string +! \newline +! n = shr\_string\_lastIndex(string,substring) +! +! !REVISION HISTORY: +! 2005-Feb-28 - First version from dshr_domain +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function shr_string_lastIndex(string,substr,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: substr ! sub-string to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_lastIndex) " + character(*),parameter :: F00 = "('(shr_string_lastIndex) ',4a)" + +!------------------------------------------------------------------------------- +! Note: +! - "new" F90 back option to index function makes this home-grown solution obsolete +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + shr_string_lastIndex = index(string,substr,.true.) + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_lastIndex + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_endIndex -- Get the ending index of substr within string +! +! !DESCRIPTION: +! Get the ending index of substr within string +! \newline +! n = shr\_string\_endIndex(string,substring) +! +! !REVISION HISTORY: +! 2005-May-10 - B. Kauffman, first version. +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function shr_string_endIndex(string,substr,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: substr ! sub-string to search for + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: i ! generic index + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_endIndex) " + character(*),parameter :: F00 = "('(shr_string_endIndex) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! * returns zero if substring not found, uses len_trim() intrinsic +! * very similar to: i = index(str,substr,back=.true.) +! * do we need this function? +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + i = index(trim(string),trim(substr)) + if ( i == 0 ) then + shr_string_endIndex = 0 ! substr is not in string + else + shr_string_endIndex = i + len_trim(substr) - 1 + end if + +! ------------------------------------------------------------------- +! i = index(trim(string),trim(substr),back=.true.) +! if (i == len(string)+1) i = 0 +! shr_string_endIndex = i +! ------------------------------------------------------------------- + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_endIndex + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_leftAlign -- remove leading white space +! +! !DESCRIPTION: +! Remove leading white space +! \newline +! call shr\_string\_leftAlign(string) +! +! !REVISION HISTORY: +! 2005-Apr-28 - B. Kauffman - First version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_leftAlign(str,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: str + integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code + +!EOP + + !----- local ---- + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_leftAlign) " + character(*),parameter :: F00 = "('(shr_string_leftAlign) ',4a)" + +!------------------------------------------------------------------------------- +! note: +! * ?? this routine isn't needed, use the intrisic adjustL instead ?? +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + +! ------------------------------------------------------------------- +! --- I used this until I discovered the intrinsic function below - BK +! do while (len_trim(str) > 0 ) +! if (str(1:1) /= ' ') exit +! str = str(2:len_trim(str)) +! end do +! rCode = 0 +! !! (len_trim(str) == 0 ) rCode = 1 ! ?? appropriate ?? +! ------------------------------------------------------------------- + + str = adjustL(str) + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_leftAlign + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_alphanum -- remove non alpha numeric characters +! +! !DESCRIPTION: +! Remove all non alpha numeric characters from string +! \newline +! call shr\_string\_alphanum(string) +! +! !REVISION HISTORY: +! 2005-Aug-01 - T. Craig - First version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_alphanum(str,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: str + integer(SHR_KIND_IN),intent(out) ,optional :: rc ! return code + +!EOP + + !----- local ---- + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: n,icnt ! counters + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_alphaNum) " + character(*),parameter :: F00 = "('(shr_string_alphaNum) ',4a)" + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + icnt = 0 + do n=1,len_trim(str) + if ((str(n:n) >= 'a' .and. str(n:n) <= 'z') .or. & + (str(n:n) >= 'A' .and. str(n:n) <= 'Z') .or. & + (str(n:n) >= '0' .and. str(n:n) <= '9')) then + icnt = icnt + 1 + str(icnt:icnt) = str(n:n) + endif + enddo + do n=icnt+1,len(str) + str(n:n) = ' ' + enddo + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_alphanum + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_betweenTags -- Get the substring between the two tags. +! +! !DESCRIPTION: +! Get the substring found between the start and end tags. +! \newline +! call shr\_string\_betweenTags(string,startTag,endTag,substring,rc) +! +! !REVISION HISTORY: +! 2005-May-11 - B. Kauffman, first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_betweenTags(string,startTag,endTag,substr,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(in) :: startTag ! start tag + character(*) ,intent(in) :: endTag ! end tag + character(*) ,intent(out) :: substr ! sub-string between tags + integer(SHR_KIND_IN),intent(out),optional :: rc ! retrun code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: iStart ! substring start index + integer(SHR_KIND_IN) :: iEnd ! substring end index + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_betweenTags) " + character(*),parameter :: F00 = "('(shr_string_betweenTags) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! * assumes the leading/trailing white space is not part of start & end tags +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + iStart = shr_string_endIndex(string,trim(adjustL(startTag))) ! end of start tag + iEnd = index(string,trim(adjustL(endTag ))) ! start of end tag + + rCode = 0 + substr = "" + + if (iStart < 1) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: can't find start tag in string" + write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 1 + else if (iEnd < 1) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: can't find end tag in string" + write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 2 + else if ( iEnd <= iStart) then + if (s_loglev > 0) then + write(s_logunit,F00) "ERROR: start tag not before end tag" + write(s_logunit,F00) "ERROR: start tag = ",trim(startTag) + write(s_logunit,F00) "ERROR: end tag = ",trim( endTag) + write(s_logunit,F00) "ERROR: string = ",trim(string) + endif + rCode = 3 + else if ( iStart+1 == iEnd ) then + substr = "" + if (s_loglev > 0) write(s_logunit,F00) "WARNING: zero-length substring found in ",trim(string) + else + substr = string(iStart+1:iEnd-1) + if (len_trim(substr) == 0 .and. s_loglev > 0) & + & write(s_logunit,F00) "WARNING: white-space substring found in ",trim(string) + end if + + if (present(rc)) rc = rCode + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_betweenTags + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_parseCFtunit -- Parse CF time unit +! +! !DESCRIPTION: +! Parse CF time unit into a delta string name and a base time in yyyymmdd +! and seconds (nearest integer actually). +! \newline +! call shr\_string\_parseCFtunit(string,substring) +! \newline +! Input string is like "days since 0001-06-15 15:20:45.5 -6:00" +! - recognizes "days", "hours", "minutes", "seconds" +! - must have at least yyyy-mm-dd, hh:mm:ss.s is optional +! - expects a "since" in the string +! - ignores time zone part +! +! !REVISION HISTORY: +! 2005-May-15 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_parseCFtunit(string,unit,bdate,bsec,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string to search + character(*) ,intent(out) :: unit ! delta time unit + integer(SHR_KIND_IN),intent(out) :: bdate ! base date yyyymmdd + real(SHR_KIND_R8) ,intent(out) :: bsec ! base seconds + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: i,i1,i2 ! generic index + character(SHR_KIND_CL) :: tbase ! baseline time + character(SHR_KIND_CL) :: lstr ! local string + integer(SHR_KIND_IN) :: yr,mo,da,hr,min ! time stuff + real(SHR_KIND_R8) :: sec ! time stuff + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_parseCFtunit) " + character(*),parameter :: F00 = "('(shr_string_parseCFtunit) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! o assume length of CF-1.0 time attribute char string < SHR_KIND_CL +! This is a reasonable assumption. +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + unit = 'none' + bdate = 0 + bsec = 0.0_SHR_KIND_R8 + + i = shr_string_lastIndex(string,'days ') + if (i > 0) unit = 'days' + i = shr_string_lastIndex(string,'hours ') + if (i > 0) unit = 'hours' + i = shr_string_lastIndex(string,'minutes ') + if (i > 0) unit = 'minutes' + i = shr_string_lastIndex(string,'seconds ') + if (i > 0) unit = 'seconds' + + if (trim(unit) == 'none') then + write(s_logunit,F00) ' ERROR time unit unknown' + call shr_string_abort(subName//' time unit unknown') + endif + + i = shr_string_lastIndex(string,' since ') + if (i < 1) then + write(s_logunit,F00) ' ERROR since does not appear in unit attribute for time ' + call shr_string_abort(subName//' no since in attr name') + endif + tbase = trim(string(i+6:)) + call shr_string_leftAlign(tbase) + + if (debug > 0 .and. s_logunit > 0) then + write(s_logunit,*) trim(subName)//' '//'unit '//trim(unit) + write(s_logunit,*) trim(subName)//' '//'tbase '//trim(tbase) + endif + + yr=0; mo=0; da=0; hr=0; min=0; sec=0 + i1 = 1 + + i2 = index(tbase,'-') - 1 + if(i2<0) goto 200 + lstr = tbase(i1:i2) + + read(lstr,*,ERR=200,END=200) yr + tbase = tbase(i2+2:) + call shr_string_leftAlign(tbase) + + i2 = index(tbase,'-') - 1 + if(i2<0) goto 200 + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=200) mo + tbase = tbase(i2+2:) + call shr_string_leftAlign(tbase) + + i2 = index(tbase,' ') - 1 + if(i2<0) i2= len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=200) da + tbase = tbase(i2+2:) + call shr_string_leftAlign(tbase) + + i2 = index(tbase,':') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) hr + tbase = tbase(i2+2:) + call shr_string_leftAlign(tbase) + + i2 = index(tbase,':') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) min + tbase = tbase(i2+2:) + call shr_string_leftAlign(tbase) + + i2 = index(tbase,' ') - 1 + if(i2<0) i2=len_trim(tbase) + lstr = tbase(i1:i2) + read(lstr,*,ERR=200,END=100) sec + +100 continue + if (debug > 0 .and. s_loglev > 0) write(s_logunit,*) trim(subName),'ymdhms:',yr,mo,da,hr,min,sec + + bdate = abs(yr)*10000 + mo*100 + da + if (yr < 0) bdate = -bdate + bsec = real(hr*3600 + min*60,SHR_KIND_R8) + sec + + if (present(rc)) rc = 0 + + if (debug>1) call shr_timer_stop (t01) + return + +200 continue + write(s_logunit,F00) 'ERROR 200 on char num read ' + call shr_string_abort(subName//' ERROR on char num read') + if (debug>1) call shr_timer_stop (t01) + return + +end subroutine shr_string_parseCFtunit + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_clean -- Clean a string, set it to "blank" +! +! !DESCRIPTION: +! Clean a string, set it to blank +! \newline +! call shr\_string\_clean(string,rc) +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_clean(string,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: string ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! counter + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_clean) " + character(*),parameter :: F00 = "('(shr_string_clean) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + string = ' ' + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_clean + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listIsValid -- determine whether string is a valid list +! +! !DESCRIPTION: +! Determine whether string is a valid list +! \newline +! logical_var = shr\_string\_listIsValid(list,rc) +! +! !REVISION HISTORY: +! 2005-May-05 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +logical function shr_string_listIsValid(list,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer (SHR_KIND_IN) :: nChar ! lenth of list + integer (SHR_KIND_IN) :: rCode ! return code + integer (SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listIsValid) " + character(*),parameter :: F00 = "('(shr_string_listIsValid) ',4a)" + +!------------------------------------------------------------------------------- +! check that the list conforms to the list format +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + shr_string_listIsValid = .true. + + nChar = len_trim(list) + if (nChar < 1) then ! list is an empty string + rCode = 1 + else if ( list(1:1) == listDel ) then ! first char is delimiter + rCode = 2 + else if (list(nChar:nChar) == listDel ) then ! last char is delimiter + rCode = 3 + else if (index(trim(list)," " ) > 0) then ! white-space in a field name + rCode = 4 + else if (index(trim(list),listDel2) > 0) then ! found zero length field + rCode = 5 + end if + + if (rCode /= 0) then + shr_string_listIsValid = .false. + if (s_loglev > 0) write(s_logunit,F00) "WARNING: invalid list = ",trim(list) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_listIsValid + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listGetName -- Get name of k-th field in list +! +! !DESCRIPTION: +! Get name of k-th field in list +! \newline +! call shr\_string\_listGetName(list,k,name,rc) +! +! !REVISION HISTORY: +! 2005-May-05 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listGetName(list,k,name,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list ! list/string + integer(SHR_KIND_IN) ,intent(in) :: k ! index of field + character(*) ,intent(out) :: name ! k-th name in list + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: i,j,n ! generic indecies + integer(SHR_KIND_IN) :: kFlds ! number of fields in list + integer(SHR_KIND_IN) :: i0,i1 ! name = list(i0:i1) + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetName) " + character(*),parameter :: F00 = "('(shr_string_listGetName) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + !--- check that this is a valid list --- + if (.not. shr_string_listIsValid(list,rCode) ) then + write(s_logunit,F00) "ERROR: invalid list = ",trim(list) + call shr_string_abort(subName//" ERROR: invalid list = "//trim(list)) + end if + + !--- check that this is a valid index --- + kFlds = shr_string_listGetNum(list) + if (k<1 .or. kFlds1) call shr_timer_stop (t01) + +end subroutine shr_string_listGetName + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listIntersect -- Get intersection of two field lists +! +! !DESCRIPTION: +! Get intersection of two fields lists, write into third list +! \newline +! call shr\_string\_listIntersect(list1,list2,listout) +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listIntersect(list1,list2,listout,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: nf,n1,n2 ! counters + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listIntersect) " + character(*),parameter :: F00 = "('(shr_string_listIntersect) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + nf = shr_string_listGetNum(list1) + call shr_string_clean(listout) + do n1 = 1,nf + call shr_string_listGetName(list1,n1,name,rCode) + n2 = shr_string_listGetIndexF(list2,name) + if (n2 > 0) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listIntersect + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listUnion -- Get union of two field lists +! +! !DESCRIPTION: +! Get union of two fields lists, write into third list +! \newline +! call shr\_string\_listUnion(list1,list2,listout) +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listUnion(list1,list2,listout,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: nf,n1,n2 ! counters + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listUnion) " + character(*),parameter :: F00 = "('(shr_string_listUnion) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + call shr_string_clean(listout) + + nf = shr_string_listGetNum(list1) + do n1 = 1,nf + call shr_string_listGetName(list1,n1,name,rCode) + n2 = shr_string_listGetIndexF(listout,name) + if (n2 < 1) then + call shr_string_listAppend(listout,name) + endif + enddo + + nf = shr_string_listGetNum(list2) + do n1 = 1,nf + call shr_string_listGetName(list2,n1,name,rCode) + n2 = shr_string_listGetIndexF(listout,name) + if (n2 < 1) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listUnion + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listDiff -- Get set difference of two field lists +! +! !DESCRIPTION: +! Get set difference of two fields lists, write into third list +! \newline +! call shr\_string\_listDiff(list1,list2,listout) +! \newline +! listout will contain all elements in list1 but not in list2 +! +! !REVISION HISTORY: +! 2015-April-24 - W. Sacks +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listDiff(list1,list2,listout,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: num_fields, index1, index2 + character(SHR_KIND_CS) :: name ! field name + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listDiff) " + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + rCode = 0 + + num_fields = shr_string_listGetNum(list1) + call shr_string_clean(listout) + do index1 = 1,num_fields + call shr_string_listGetName(list1,index1,name,rCode) + index2 = shr_string_listGetIndexF(list2,name) + if (index2 <= 0) then + call shr_string_listAppend(listout,name) + endif + enddo + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listDiff + + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listMerge -- Merge lists two list to third +! +! !DESCRIPTION: +! Merge two list to third +! \newline +! call shr\_string\_listMerge(list1,list2,listout) +! call shr\_string\_listMerge(list1,list2,list1) +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listMerge(list1,list2,listout,rc) + + implicit none +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: list1 ! list/string + character(*) ,intent(in) :: list2 ! list/string + character(*) ,intent(out) :: listout ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + character(SHR_KIND_CX) :: l1,l2 ! local char strings + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listMerge) " + character(*),parameter :: F00 = "('(shr_string_listMerge) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! - no input or output string should be longer than SHR_KIND_CX +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + !--- make sure temp strings are large enough --- + if ( (len(l1) < len_trim(list1)) .or. (len(l2) < len_trim(list2))) then + call shr_string_abort(subName//'ERROR: temp string not large enough') + end if + + call shr_string_clean(l1) + call shr_string_clean(l2) + call shr_string_clean(listout) + l1 = trim(list1) + l2 = trim(list2) + call shr_string_leftAlign(l1,rCode) + call shr_string_leftAlign(l2,rCode) + if (len_trim(l1)+len_trim(l2)+1 > len(listout)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(l1) == 0) then + listout = trim(l2) + else + listout = trim(l1)//":"//trim(l2) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listMerge + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listAppend -- Append one list to another +! +! !DESCRIPTION: +! Append one list to another +! \newline +! call shr\_string\_listAppend(list,listadd) +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listAppend(list,listadd,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(inout) :: list ! list/string + character(*) ,intent(in) :: listadd ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + character(SHR_KIND_CX) :: l1 ! local string + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listAppend) " + character(*),parameter :: F00 = "('(shr_string_listAppend) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! - no input or output string should be longer than SHR_KIND_CX +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + !--- make sure temp string is large enough --- + if (len(l1) < len_trim(listAdd)) then + call shr_string_abort(subName//'ERROR: temp string not large enough') + end if + + call shr_string_clean(l1) + l1 = trim(listadd) + call shr_string_leftAlign(l1,rCode) + if (len_trim(list)+len_trim(l1)+1 > len(list)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(list) == 0) then + list = trim(l1) + else + list = trim(list)//":"//trim(l1) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listAppend + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listPrepend -- Prepend one list to another +! +! !DESCRIPTION: +! Prepend one list to another +! \newline +! call shr\_string\_listPrepend(listadd,list) +! \newline +! results in listadd:list +! +! !REVISION HISTORY: +! 2005-May-05 - T. Craig +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listPrepend(listadd,list,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: listadd ! list/string + character(*) ,intent(inout) :: list ! list/string + integer(SHR_KIND_IN),optional,intent(out) :: rc ! return code + +!EOP + + !----- local ----- + character(SHR_KIND_CX) :: l1 ! local string + integer(SHR_KIND_IN) :: rCode ! return code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listPrepend) " + character(*),parameter :: F00 = "('(shr_string_listPrepend) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! - no input or output string should be longer than SHR_KIND_CX +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + rCode = 0 + + !--- make sure temp string is large enough --- + if (len(l1) < len_trim(listAdd)) then + call shr_string_abort(subName//'ERROR: temp string not large enough') + end if + + call shr_string_clean(l1) + l1 = trim(listadd) + call shr_string_leftAlign(l1,rCode) + call shr_string_leftAlign(list,rCode) + if (len_trim(list)+len_trim(l1)+1 > len(list)) & + call shr_string_abort(subName//'ERROR: output list string not large enough') + if (len_trim(l1) == 0) then + list = trim(list) + else + list = trim(l1)//":"//trim(list) + endif + + if (present(rc)) rc = rCode + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listPrepend + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listGetIndexF -- Get index of field in string +! +! !DESCRIPTION: +! Get index of field in string +! \newline +! k = shr\_string\_listGetIndex(str,"taux") +! +! !REVISION HISTORY: +! 2005-Feb-28 - B. Kauffman and J. Schramm - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function shr_string_listGetIndexF(string,fldStr) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: string ! string + character(*),intent(in) :: fldStr ! name of field + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: k ! local index variable + integer(SHR_KIND_IN) :: rc ! error code + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetIndexF) " + character(*),parameter :: F00 = "('(shr_string_listGetIndexF) ',4a)" + +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + call shr_string_listGetIndex(string,fldStr,k,print=.false.,rc=rc) + shr_string_listGetIndexF = k + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_listGetIndexF + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listGetIndex -- Get index of field in string +! +! !DESCRIPTION: +! Get index of field in string +! \newline +! call shr\_string\_listGetIndex(str,"taux",k,rc) +! +! !REVISION HISTORY: +! 2005-Feb-28 - B. Kauffman and J. Schramm - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listGetIndex(string,fldStr,kFld,print,rc) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*) ,intent(in) :: string ! string + character(*) ,intent(in) :: fldStr ! name of field + integer(SHR_KIND_IN),intent(out) :: kFld ! index of field + logical ,intent(in) ,optional :: print ! print switch + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: n ! index for colon position + integer(SHR_KIND_IN) :: k ! index for field name position + integer(SHR_KIND_IN) :: nFields ! number of fields in a string + integer(SHR_KIND_IN) :: i0,i1 ! fldStr == string(i0,i1) ?? + integer(SHR_KIND_IN) :: j0,j1 ! fldStr == string(j0,j1) ?? + logical :: found ! T => field found in fieldNames + logical :: lprint ! local print flag + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetIndex) " + character(*),parameter :: F00 = "('(shr_string_listGetIndex) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +! - searching from both ends of the list at the same time seems to be 20% faster +! but I'm not sure why (B. Kauffman, Feb 2007) +! - I commented out sanity check to a little gain speed (B. Kauffman, Mar 2007) +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + if (present(rc)) rc = 0 + + lprint = .false. + if (present(print)) lprint = print + + !--- confirm proper size of input data --- + if (len_trim(fldStr) < 1) then + if (lprint) write(s_logunit,F00) "ERROR: input field name has 0 length" + call shr_string_abort(subName//"invalid field name") + end if + + !--- search for field name in string's list of fields --- + found = .false. + kFld = 0 + i0 = 1 ! ?? fldStr == string(i0:i1) ?? + i1 = -1 + j0 = -1 ! ?? fldStr == string(j0:j1) ?? + j1 = len_trim(string) + nFields = shr_string_listGetNum(string) + do k = 1,nFields + !-------------------------------------------------------- + ! search from end of list to end of list + !-------------------------------------------------------- + !--- get end index of of field number k --- + n = index(string(i0:len_trim(string)),listDel) + if (n > 0) then + i1 = i0 + n - 2 ! *not* the last field name in fieldNames + else + i1 = len_trim(string) ! this is the last field name in fieldNames + endif + !--- sanity check --- + ! if ((k 0)) then + ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") + ! end if + !--- is it a match? --- + if (trim(fldStr) == string(i0:i1)) then + found = .true. + kFld = k + exit + endif + i0 = i1 + 2 ! start index for next iteration + !-------------------------------------------------------- + ! search from end of list to start of list + !-------------------------------------------------------- + !--- get start index of field number (nFields + 1 - k ) --- + n = index(string(1:j1),listDel,back=.true.) + j0 = n + 1 ! n==0 => the first field name in fieldNames + !--- sanity check --- + ! if ((k 0)) then + ! call shr_string_abort(subName//"ERROR: wrong string%nf ?") + ! end if + !--- is it a match? --- + if (trim(fldStr) == string(j0:j1)) then + found = .true. + kFld = nFields + 1 - k + exit + endif + j1 = j0 - 2 ! end index for next iteration + !-------------------------------------------------------- + ! exit if all field names have been checked + !-------------------------------------------------------- + if (2*k >= nFields) exit + end do + + !--- not finding a field is not a fatal error --- + if (.not. found) then + kFld = 0 + if (lprint .and. s_loglev > 0) write(s_logunit,F00) "FYI: field ",trim(fldStr)," not found in list ",trim(string) + if (present(rc)) rc = 1 + end if + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listGetIndex + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listGetNum -- get number of fields in a string list +! +! !DESCRIPTION: +! return number of fields in string list +! +! !REVISION HISTORY: +! 2005-Apr-28 - T. Craig - First version +! +! !INTERFACE: ------------------------------------------------------------------ + +integer function shr_string_listGetNum(str) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(in) :: str ! string to search + +!EOP + + !----- local ----- + integer(SHR_KIND_IN) :: count ! counts occurances of char + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !----- formats ----- + character(*),parameter :: subName = "(shr_string_listGetNum) " + character(*),parameter :: F00 = "('(shr_string_listGetNum) ',4a)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + shr_string_listGetNum = 0 + + if (len_trim(str) > 0) then + count = shr_string_countChar(str,listDel) + shr_string_listGetNum = count + 1 + endif + + if (debug>1) call shr_timer_stop (t01) + +end function shr_string_listGetNum + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listSetDel -- Set list delimiter character +! +! !DESCRIPTION: +! Set field delimiter character in lists +! \newline +! call shr\_string\_listSetDel(":") +! +! !REVISION HISTORY: +! 2005-Apr-30 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listSetDel(cflag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(len=1),intent(in) :: cflag + +!EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listSetDel) " + character(*),parameter :: F00 = "('(shr_string_listSetDel) ',a) " + +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + if (debug > 0 .and. s_loglev > 0) write(s_logunit,F00) 'changing listDel from '//trim(listDel)//' to '//trim(cflag) + listDel = trim(cflag) + listDel2 = listDel//listDel + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listSetDel + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_listGetDel -- Get list delimiter character +! +! !DESCRIPTION: +! Get field delimiter character in lists +! \newline +! call shr\_string\_listGetDel(del) +! +! !REVISION HISTORY: +! 2005-May-15 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_listGetDel(del) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),intent(out) :: del + +!EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listGetDel) " + character(*),parameter :: F00 = "('(shr_string_listGetDel) ',a) " + +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + del = trim(listDel) + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_listGetDel + +!=============================================================================== +! +! shr_string_listCreateField +! +! Returns a string of colon delimited fields for use in shr_strdata_create +! arguments, fldListFile and fldListModel. +! Use to create actual args for shr_strdata_create (fldListFile and +! flidListModel). +! +! This works for numFields up to 999. Modify the string write if you want +! more range. +! +! retString = shr_string_listCreateField(numFields, strBase) +! given numFields = 5 and strBase = LAI, returns: +! LAI_1:LAI_2:LAI_3:LAI_4:LAI_5 +! +!=============================================================================== +function shr_string_listCreateField( numFields, strBase ) result ( retString ) + + implicit none + + integer(SHR_KIND_IN), intent(in) :: numFields ! number of fields + character(len=*) , intent(in) :: strBase ! input string base + character(SHR_KIND_CXX) :: retString ! colon delimited field list + + integer :: idx ! index for looping over numFields + integer(SHR_KIND_IN) :: t01 = 0 ! timer + character(SHR_KIND_CX) :: tmpString ! temporary + character(SHR_KIND_CX) :: intAsChar ! temporary + character(1), parameter :: colonStr = ':' + character(1), parameter :: underStr = '_' + + !--- formats --- + character(*),parameter :: subName = "(shr_string_listCreateField) " + character(*),parameter :: F00 = "('(shr_string_listCreateField) ',a) " + +!------------------------------------------------------------------------------- + + if ( debug > 1 .and. t01 < 1 ) call shr_timer_get( t01,subName ) + if ( debug > 1 ) call shr_timer_start( t01 ) + + ! + ! this assert isn't that accurate since it counts all integers as being one + ! digit, but it should catch most errors and under rather than overestimates + ! + SHR_ASSERT( ( ( ( len(strBase) + 3 ) * numFields ) <= 1024 ) , errMsg(__FILE__, __LINE__) ) + + retString = '' + do idx = 1,numFields + + ! reset temps per numField + intAsChar = '' + tmpString = '' + + ! string conversion based on 1,2,3 digits + if ( idx < 10 ) then + write(intAsChar, "(I1)") idx + else if ( idx >= 10 .and. idx < 100 ) then + write(intAsChar, "(I2)") idx + else + write(intAsChar, "(I3)") idx + end if + + tmpString = trim(StrBase)//trim(underStr)//trim(intAsChar) + + if ( idx > 1 ) then + tmpString = trim(colonStr)//trim(tmpString) + end if + + retString = trim(retString)//trim(tmpString) + + end do + + if ( debug > 1 ) call shr_timer_stop ( t01 ) + +end function shr_string_listCreateField + +!=============================================================================== +! +! shr_string_listAddSuffix +! +! Given an existing list and a suffix, returns a new list with that suffix added to the +! end of every field in the list. +! +! call shr_string_listAddSuffix('a:b:c', '00', new_list) +! gives new_list = 'a00:b00:c00' +! +!=============================================================================== +subroutine shr_string_listAddSuffix(list, suffix, new_list) + + implicit none + + character(len=*), intent(in) :: list + character(len=*), intent(in) :: suffix + character(len=*), intent(out) :: new_list + + integer :: num_fields + integer :: field_num + character(SHR_KIND_CS) :: this_field + character(len(this_field) + len(suffix)) :: this_field_with_suffix + character(len(new_list)) :: temp_list + + num_fields = shr_string_listGetNum(list) + new_list = ' ' + + do field_num = 1, num_fields + call shr_string_listGetName(list, field_num, this_field) + this_field_with_suffix = trim(this_field) // suffix + temp_list = new_list + call shr_string_listMerge(temp_list, this_field_with_suffix, new_list) + end do +end subroutine shr_string_listAddSuffix + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_setAbort -- Set local shr_string abort flag +! +! !DESCRIPTION: +! Set local shr_string abort flag, true = abort, false = print and continue +! \newline +! call shr\_string\_setAbort(.false.) +! +! !REVISION HISTORY: +! 2005-Apr-30 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_setAbort(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + +!EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_setAbort) " + character(*),parameter :: F00 = "('(shr_string_setAbort) ',a) " + +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + if (debug > 0 .and. s_loglev > 0) then + if (flag) then + write(s_logunit,F00) 'setting abort to true' + else + write(s_logunit,F00) 'setting abort to false' + endif + endif + + doabort = flag + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_setAbort + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_string_setDebug -- Set local shr_string debug level +! +! !DESCRIPTION: +! Set local shr_string debug level, 0 = production +! \newline +! call shr\_string\_setDebug(2) +! +! !REVISION HISTORY: +! 2005-Apr-30 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_string_setDebug(iFlag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: iFlag ! requested debug level + +!EOP + + !--- local --- + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- formats --- + character(*),parameter :: subName = "(shr_string_setDebug) " + character(*),parameter :: F00 = "('(shr_string_setDebug) ',a) " + character(*),parameter :: F01 = "('(shr_string_setDebug) ',a,i3,a,i3) " + +!------------------------------------------------------------------------------- +! NTOE: write statement can be expensive if called many times. +!------------------------------------------------------------------------------- + + if (iFlag>1 .and. t01<1) call shr_timer_get(t01,subName) + if (iFlag>1) call shr_timer_start(t01) + +! if (s_loglev > 0) write(s_logunit,F01) 'changing debug level from ',debug,' to ',iflag + debug = iFlag + + if (iFlag>1) call shr_timer_stop (t01) + +end subroutine shr_string_setDebug + +!=============================================================================== +!=============================================================================== + +subroutine shr_string_abort(string) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),optional,intent(in) :: string + +!EOP + + integer(SHR_KIND_IN) :: t01 = 0 ! timer + + !--- local --- + character(SHR_KIND_CX) :: lstring + character(*),parameter :: subName = "(shr_string_abort)" + character(*),parameter :: F00 = "('(shr_string_abort) ',a)" + +!------------------------------------------------------------------------------- +! NOTE: +! - no input or output string should be longer than SHR_KIND_CX +!------------------------------------------------------------------------------- + + if (debug>1 .and. t01<1) call shr_timer_get(t01,subName) + if (debug>1) call shr_timer_start(t01) + + lstring = '' + if (present(string)) lstring = string + + if (doabort) then + call shr_sys_abort(trim(lstring)) + else + write(s_logunit,F00) ' no abort:'//trim(lstring) + endif + + if (debug>1) call shr_timer_stop (t01) + +end subroutine shr_string_abort + +!=============================================================================== +!=============================================================================== + +end module shr_string_mod diff --git a/share/csm_share/shr/shr_sys_mod.F90 b/share/csm_share/shr/shr_sys_mod.F90 new file mode 100644 index 000000000000..2ba7eb89fd4d --- /dev/null +++ b/share/csm_share/shr/shr_sys_mod.F90 @@ -0,0 +1,455 @@ +!=============================================================================== +! SVN $Id: shr_sys_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_sys_mod.F90 $ +!=============================================================================== + +! Currently supported by all compilers +#define HAVE_GET_ENVIRONMENT +#define HAVE_SLEEP + +! Except this combination? +#if defined CPRPGI && defined CNL +#undef HAVE_GET_ENVIRONMENT +#endif + +#if defined CPRNAG +#define HAVE_EXECUTE +#endif + +MODULE shr_sys_mod + + use, intrinsic :: iso_fortran_env, only: output_unit, error_unit + + use shr_kind_mod ! defines real & integer kinds + use shr_mpi_mod ! wraps MPI layer + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + +#ifdef CPRNAG + ! NAG does not provide these as intrinsics, but it does provide modules + ! that implement commonly used POSIX routines. + use f90_unix_dir, only: chdir + use f90_unix_proc, only: abort, sleep +#endif + + implicit none + +! PUBLIC: Public interfaces + + private + + public :: shr_sys_system ! make a system call + public :: shr_sys_chdir ! change current working dir + public :: shr_sys_getenv ! get an environment variable + public :: shr_sys_abort ! abort a program + public :: shr_sys_irtc ! returns real-time clock tick + public :: shr_sys_sleep ! have program sleep for a while + public :: shr_sys_flush ! flush an i/o buffer + public :: shr_sys_backtrace ! print a backtrace, if possible + +!=============================================================================== +CONTAINS +!=============================================================================== + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_system(str,rcode) + + IMPLICIT none + + !----- arguments --- + character(*) ,intent(in) :: str ! system/shell command string + integer(SHR_KIND_IN),intent(out) :: rcode ! function return error code + + !----- functions ----- +#if (defined LINUX && !defined CPRGNU) + integer(SHR_KIND_IN),external :: system ! function to envoke shell command +#endif + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_system) ' + character(*),parameter :: F00 = "('(shr_sys_system) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + rcode = 0 +#ifdef HAVE_EXECUTE + call execute_command_line(str,exitstat=rcode) ! Intrinsic as of F2008 +#else +#if (defined AIX) + + call system(str,rcode) + +#elif (defined CPRGNU || defined LINUX) + + rcode = system(str) + +#else + + write(s_logunit,F00) 'ERROR: no implementation of system call for this architecture' + call shr_sys_abort(subName//'no implementation of system call for this architecture') +#endif +#endif + +END SUBROUTINE shr_sys_system + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_chdir(path, rcode) + + IMPLICIT none + + !----- arguments ----- + character(*) ,intent(in) :: path ! chdir to this dir + integer(SHR_KIND_IN),intent(out) :: rcode ! return code + + !----- local ----- + integer(SHR_KIND_IN) :: lenpath ! length of path +#if (defined AIX || (defined LINUX && !defined CPRGNU && !defined CPRNAG) || defined CPRINTEL) + integer(SHR_KIND_IN),external :: chdir ! AIX system call +#endif + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_chdir) ' + character(*),parameter :: F00 = "('(shr_sys_chdir) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + + lenpath=len_trim(path) + +#if (defined AIX) + + rcode = chdir(%ref(path(1:lenpath)//'\0')) + +#elif (defined Darwin || (defined LINUX && !defined CPRNAG)) + + rcode=chdir(path(1:lenpath)) + +#elif (defined CPRNAG) + + call chdir(path(1:lenpath), errno=rcode) + +#else + + write(s_logunit,F00) 'ERROR: no implementation of chdir for this architecture' + call shr_sys_abort(subname//'no implementation of chdir for this machine') + +#endif + +END SUBROUTINE shr_sys_chdir + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_getenv(name, val, rcode) + + IMPLICIT none + + !----- arguments ----- + character(*) ,intent(in) :: name ! env var name + character(*) ,intent(out) :: val ! env var value + integer(SHR_KIND_IN),intent(out) :: rcode ! return code + + !----- local ----- + integer(SHR_KIND_IN) :: lenname ! length of env var name + integer(SHR_KIND_IN) :: lenval ! length of env var value + character(SHR_KIND_CL) :: tmpval ! temporary env var value + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_getenv) ' + character(*),parameter :: F00 = "('(shr_sys_getenv) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +!------------------------------------------------------------------------------- + +!$OMP master + + +#ifdef HAVE_GET_ENVIRONMENT + call get_environment_variable(name=name,value=val,status=rcode) ! Intrinsic in F2003 +#else + lenname=len_trim(name) +#if (defined AIX || defined LINUX) + + call getenv(trim(name),tmpval) + val=trim(tmpval) + rcode = 0 + if (len_trim(val) == 0 ) rcode = 1 + if (len_trim(val) > SHR_KIND_CL) rcode = 2 + +#else + + write(s_logunit,F00) 'ERROR: no implementation of getenv for this architecture' + call shr_sys_abort(subname//'no implementation of getenv for this machine') + +#endif +#endif +!$OMP end master + +END SUBROUTINE shr_sys_getenv + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_abort(string,rc) + + IMPLICIT none + + character(*) ,optional :: string ! error message string + integer(SHR_KIND_IN),optional :: rc ! error code + + !----- local ----- + logical :: flag + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_abort) ' + character(*),parameter :: F00 = "('(shr_sys_abort) ',4a)" + + ! Local version of the string. + ! (Gets a default value if string is not present.) + character(len=shr_kind_cx) :: local_string + +!------------------------------------------------------------------------------- +! PURPOSE: consistent stopping mechanism +!------------------------------------------------------------------------------- + + if (present(string)) then + local_string = trim(string) + else + local_string = "Unknown error submitted to shr_sys_abort." + end if + + call print_error_to_logs("ERROR", local_string) + + call shr_sys_backtrace() + + call shr_mpi_initialized(flag) + + if (flag) then + if (present(rc)) then + call shr_mpi_abort(trim(local_string),rc) + else + call shr_mpi_abort(trim(local_string)) + endif + endif + + ! A compiler's abort method may print a backtrace or do other nice + ! things, but in fact we can rarely leverage this, because MPI_Abort + ! usually sends SIGTERM to the process, and we don't catch that signal. + call abort() + +END SUBROUTINE shr_sys_abort + +!=============================================================================== +!=============================================================================== + +integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_I8), optional :: rate + + !----- local ----- + integer(SHR_KIND_IN) :: count + integer(SHR_KIND_IN) :: count_rate + integer(SHR_KIND_IN) :: count_max + integer(SHR_KIND_IN),save :: last_count = -1 + integer(SHR_KIND_I8),save :: count_offset = 0 + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_irtc) ' + character(*),parameter :: F00 = "('(shr_sys_irtc) ',4a)" + +!------------------------------------------------------------------------------- +! emulates Cray/SGI irtc function (returns clock tick since last reboot) +!------------------------------------------------------------------------------- + + call system_clock(count=count,count_rate=count_rate, count_max=count_max) + if ( present(rate) ) rate = count_rate + shr_sys_irtc = count + + !--- adjust for clock wrap-around --- + if ( last_count /= -1 ) then + if ( count < last_count ) count_offset = count_offset + count_max + end if + shr_sys_irtc = shr_sys_irtc + count_offset + last_count = count + +END FUNCTION shr_sys_irtc + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_sleep(sec) + + IMPLICIT none + + !----- arguments ----- + real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep + + !----- local ----- + integer(SHR_KIND_IN) :: isec ! integer number of seconds + integer(SHR_KIND_IN) :: rcode ! return code + character(90) :: str ! system call string + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_sleep) ' + character(*),parameter :: F00 = "('(shr_sys_sleep) ',4a)" + character(*),parameter :: F10 = "('sleep ',i8 )" + +!------------------------------------------------------------------------------- +! PURPOSE: Sleep for approximately sec seconds +!------------------------------------------------------------------------------- + + isec = nint(sec) + + if (isec < 0) then + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec + else if (isec == 0) then + ! Don't consider this an error and don't call system sleep + else +#ifdef HAVE_SLEEP + call sleep(isec) +#else + write(str,FMT=F10) isec + call shr_sys_system( str, rcode ) +#endif + endif + +END SUBROUTINE shr_sys_sleep + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_flush(unit) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit + + !----- local ----- + integer(SHR_KIND_IN) :: ierr ! error code + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_flush) ' + character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independent system call +! +! This is probably no longer needed; the "flush" statement is supported by +! all compilers that CESM supports for years now. +! +!------------------------------------------------------------------------------- + flush(unit) +! +! The following code was originally present, but there's an obvious issue. +! Since shr_sys_flush is usually used to flush output to a log, when it +! returns an error, does it do any good to print that error to the log? +! +! if (ierr > 0) then +! write(s_logunit,*) subname,' Flush reports error: ',ierr +! endif +! + +END SUBROUTINE shr_sys_flush + +!=============================================================================== +!=============================================================================== + +subroutine shr_sys_backtrace() + + ! This routine uses compiler-specific facilities to print a backtrace to + ! error_unit (standard error, usually unit 0). + +#if defined(CPRIBM) + + ! This theoretically should be in xlfutility, but using it from that + ! module doesn't seem to always work. + interface + subroutine xl_trbk() + end subroutine xl_trbk + end interface + + call xl__trbk() + +#elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) + + ! gfortran 4.8 and later implement this intrinsic. We explicitly call it + ! out as such to make sure that it really is available, just in case the + ! CPP logic above screws up. + intrinsic :: backtrace + + call backtrace() + +#elif defined(CPRINTEL) + + ! tracebackqq uses optional arguments, so *must* have an explicit + ! interface. + use ifcore, only: tracebackqq + + ! An exit code of -1 is a special value that prevents this subroutine + ! from aborting the run. + call tracebackqq(user_exit_code=-1) + +#else + + ! Currently we have no means to request a backtrace from the NAG runtime, + ! even though it is capable of emitting backtraces itself, if you use the + ! "-gline" option. + + ! Similarly, PGI has a -traceback option, but no user interface for + ! requesting a backtrace to be printed. + +#endif + + flush(error_unit) + +end subroutine shr_sys_backtrace + +!=============================================================================== +!=============================================================================== + +! +! This routine prints error messages to s_logunit (which is standard output +! for most tasks in CESM) and also to standard error if s_logunit is a +! file. +! +! It also flushes these output units. +! +subroutine print_error_to_logs(error_type, message) + character(len=*), intent(in) :: error_type, message + + integer, allocatable :: log_units(:) + + integer :: i + + if (s_logunit == output_unit .or. s_logunit == error_unit) then + ! If the log unit number is standard output or standard error, just + ! print to that. + allocate(log_units(1), source=[s_logunit]) + else + ! Otherwise print the same message to both the log unit and standard + ! error. + allocate(log_units(2), source=[error_unit, s_logunit]) + end if + + do i = 1, size(log_units) + write(log_units(i),*) trim(error_type), ": ", trim(message) + flush(log_units(i)) + end do + +end subroutine print_error_to_logs + +!=============================================================================== +!=============================================================================== + +END MODULE shr_sys_mod diff --git a/share/csm_share/shr/shr_tInterp_mod.F90 b/share/csm_share/shr/shr_tInterp_mod.F90 new file mode 100644 index 000000000000..9d24b714a424 --- /dev/null +++ b/share/csm_share/shr/shr_tInterp_mod.F90 @@ -0,0 +1,565 @@ +!=============================================================================== +! SVN $Id: shr_tInterp_mod.F90 34891 2012-02-19 21:34:49Z tcraig $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_tInterp_mod.F90 $ +!=============================================================================== +!BOP =========================================================================== +! +! !MODULE: shr_tInterp_mod -- time interpolation routines +! +! !DESCRIPTION: +! shared time interpolation factor routines +! +! !REVISION HISTORY: +! 2004-Dec-10 - J. Schramm - first version +! 2005-Apr-10 - T. Craig - updated for shr bundles +! +! !INTERFACE: ------------------------------------------------------------------ + +module shr_tInterp_mod + +! !USES: + + use shr_sys_mod ! shared system calls + use shr_cal_mod ! shared calendar type and methods + use shr_kind_mod ! kinds for strong typing + use shr_const_mod ! shared constants + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + use shr_orb_mod, only: shr_orb_cosz, shr_orb_decl + use esmf + + implicit none + + private ! except + +! !PUBLIC TYPES: + + ! no public types + +! !PUBLIC MEMBER FUNCTIONS: + + public :: shr_tInterp_getFactors ! get time-interp factors + public :: shr_tInterp_getAvgCosz ! get cosz, time avg of + public :: shr_tInterp_getCosz ! get cosz + public :: shr_tInterp_setAbort ! set abort on error + public :: shr_tInterp_setDebug ! set debug level + public :: shr_tInterp_getDebug ! get debug level + +! !PUBLIC DATA MEMBERS: + + ! no public data + +!EOP + + real(SHR_KIND_R8),parameter :: c0 = 0.0_SHR_KIND_R8 + real(SHR_KIND_R8),parameter :: c1 = 1.0_SHR_KIND_R8 + real(SHR_KIND_R8),parameter :: eps = 1.0E-12_SHR_KIND_R8 + + logical ,save :: doabort = .true. + integer ,save :: debug = 0 + +!=============================================================================== +contains +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_getFactors -- calculate time interpolation factors +! +! !DESCRIPTION: +! Returns two interpolation factors +! Legal algorithms are (algo): +! lower - sets factors to data 1 (lower-bound), f1=1, f2=0 +! upper - sets factors to data 2 (upper-bound), f1=0, f2=1 +! nearest - sets factors to nearest data in time +! linear - sets factors to linear interpolation between lb and ub +! \newline +! call shr\_tInterp\_getFactors(D1,s1,D2,s2,D,s,f1,f2,'linear',rc) +! \newline +! time of 2 >= time of 1 for all algos +! time of 2 >= time of model data >= time of 1 for linear +! +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_getFactors(D1,S1,D2,S2,Din,Sin,f1,f2,calendar,algo,rc) + + implicit none + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: D1,S1 ! LB date & sec (20010115,3600) + integer(SHR_KIND_IN),intent(in) :: D2,S2 ! UB date & sec + integer(SHR_KIND_IN),intent(in) :: Din,Sin ! desired/model date & sec + real(SHR_KIND_R8) ,intent(out) :: f1 ! wgt for 1 + real(SHR_KIND_R8) ,intent(out) :: f2 ! wgt for 2 + character(*) ,intent(in) :: calendar!calendar type + character(*) ,intent(in) ,optional :: algo ! algorithm + integer(SHR_KIND_IN),intent(out),optional :: rc ! return code + +!EOP + + !----- local ------ + type(ESMF_Time) :: itime1 ! time for 1 (lower-bound) + type(ESMF_Time) :: itime2 ! time for 2 (upper-bound) + type(ESMF_Time) :: itimeIn ! time for model date + type(ESMF_TimeInterval):: timeint ! timeinterval + integer(SHR_KIND_I8) :: snum, sden ! delta times in seconds + integer(SHR_KIND_I8) :: sint1,sint2 ! delta times in seconds + character(SHR_KIND_CS) :: lalgo ! local algo variable + integer(SHR_KIND_IN) :: lrc ! local rc + + !----- formats ----- + character(*),parameter :: subName = "(shr_tInterp_getFactors) " + character(*),parameter :: F00 = "('(shr_tInterp_getFactors) ',8a)" + character(*),parameter :: F01 = "('(shr_tInterp_getFactors) ',a,2f17.8)" + character(*),parameter :: F02 = "('(shr_tInterp_getFactors) ',a,3i9)" + character(*),parameter :: F03 = "('(shr_tInterp_getFactors) ',2a,3(i9.8,i6))" + +!------------------------------------------------------------------------------- +! Computes time interpolation factors +!------------------------------------------------------------------------------- + + lrc = 0 + + if (present(algo)) then + lalgo = algo + else + lalgo = 'linear' + endif + + !--- compute elapsed time --- + + call shr_cal_timeSet(itimein,Din,Sin,calendar) + call shr_cal_timeSet(itime1 ,D1 ,S1 ,calendar) + call shr_cal_timeSet(itime2 ,D2 ,S2 ,calendar) + + !DML +! write(s_logunit,*) subName,' DTIME ',Din,D1,D2 +! write(s_logunit,*) subName,' STIME ',sin,s1,s2 +! write(s_logunit,*) subName,' ETIME ',etime1,etime2,etimein +! write(s_logunit,*) subName,' ITIME ',itime1,itime2,itimein + + ! --- always check that 1 <= 2, although we could relax this requirement --- + if (itime2 < itime1) then + if (s_loglev > 0) write(s_logunit,F01) ' ERROR: itime2 < itime1 D=',D1,S1,D2,S2 + lrc = 1 + call shr_tInterp_abort(subName//' itime2 < itime1 ') + endif + + f1 = -1.0 + ! --- set interpolation factors --- + if (trim(lalgo) == 'lower') then + if (itime1 < itime2) then + f1 = c1 + else + f1 = c0 + endif + elseif (trim(lalgo) == 'upper') then + if (itime1 < itime2) then + f1 = c0 + else + f1 = c1 + endif + elseif (trim(lalgo) == 'nearest') then + timeint = itime1-itimein + call ESMF_TimeIntervalGet(timeint,StartTimeIn=itimein,s_i8=sint1) + timeint = itime2-itimein + call ESMF_TimeIntervalGet(timeint,StartTimeIn=itimein,s_i8=sint2) + if (abs(sint1) <= abs(sint2)) then + f1 = c1 + else + f1 = c0 + endif + elseif (trim(lalgo) == 'linear') then + !--- check that itimein is between itime1 and itime2 --- + if (itime2 < itimein .or. itime1 > itimein) then + write(s_logunit,F02) ' ERROR illegal linear times: ',D1,S1,Din,Sin,D2,S2 + lrc = 1 + call shr_tInterp_abort(subName//' illegal itimes ') + endif + if (itime2 == itime1) then + f1 = 0.5_SHR_KIND_R8 + else + timeint = itime2 - itimein + call ESMF_TimeIntervalGet(timeint,StartTimeIn=itimein,s_i8=snum) + timeint = itime2 - itime1 + call ESMF_TimeIntervalGet(timeint,StartTimeIn=itime1,s_i8=sden) + f1 = real(snum,SHR_KIND_R8)/real(sden,SHR_KIND_R8) + endif + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: illegal lalgo option: ',trim(lalgo) + lrc = 1 + call shr_tInterp_abort(subName//' illegal algo option '//trim(lalgo)) + endif + + f2 = c1 - f1 + + !--- check that f1 and f2 are OK, each between 0 and 1 and they sum to 1 --- + if (f1 < c0-eps .or. f1 > c1+eps .or. & + f2 < c0-eps .or. f2 > c1+eps .or. & + abs(f1+f2-c1) > eps) then + if (s_loglev > 0) write(s_logunit,F01) 'ERROR: illegal tInterp values ',f1,f2 + lrc = 1 + call shr_tInterp_abort(subName//' illegal tInterp values ') + endif + + if (debug > 0 .and. s_loglev > 0) then + write(s_logunit,F03) 'DEBUG: algo,D1,S1,Din,Sin,D2,S2=',trim(lAlgo),D1,S1,Din,Sin,D2,S2 + write(s_logunit,F01) 'DEBUG: algo,f1,f2= '//trim(lAlgo),f1,f2 + endif + + if (present(rc)) rc = lrc + +end subroutine shr_tInterp_getFactors + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_getAvgCosz -- returns avg cos(z) between LB and UB +! +! !DESCRIPTION: +! +! Returns a time-average of cos(z) over the time interval [LB,UB]. +! The time-avg is calculated via a right-sum Riemann sum where the partitian +! width is the model dt, and the left-most partitian starts at the LB. +! +! NOTE: For cosine of solar zenith angle forcing the time-stamps MUST be for +! the beginning of the interval. +! +! !REVISION HISTORY: +! 2010-Apr - B. Kauffman - change to t-avg cosz computation, uses model dt +! 2009-Oct - T. Craig - migrated from dshr code +! 2008-Jun - E. Kluzek - first version +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_getAvgCosz(tavCosz,lonr,latr,ymd1,tod1,ymd2,tod2,eccen,mvelpp,lambm0,obliqr,dt,& + calendar) + + implicit none + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + real(SHR_KIND_R8) ,intent(out) :: tavCosz(:) ! t-avg of cosz over [LB,UB] + real(SHR_KIND_R8) ,intent(in) :: latr(:) ! latitude + real(SHR_KIND_R8) ,intent(in) :: lonr(:) ! longitude + integer(SHR_KIND_IN),intent(in) :: ymd1,tod1 ! date of lb + integer(SHR_KIND_IN),intent(in) :: ymd2,tod2 ! date of ub + real(SHR_KIND_R8) ,intent(in) :: eccen ! orb param + real(SHR_KIND_R8) ,intent(in) :: mvelpp ! orb param + real(SHR_KIND_R8) ,intent(in) :: lambm0 ! orb param + real(SHR_KIND_R8) ,intent(in) :: obliqr ! orb param + integer(SHR_KIND_IN),intent(in) :: dt ! model time step in secs + character(*) ,intent(in) :: calendar ! calendar type + +!EOP + + !----- local ------ + integer(SHR_KIND_IN) :: lsize ! size of local data + type(ESMF_Time) :: reday1, reday2 ! LB, UB time + type(ESMF_TimeInterval) :: timeint ! time interval + integer(SHR_KIND_I8) :: n ! number of time-samples in t-avg + type(ESMF_Time) :: reday,reday0 ! time sample's elapsed seconds + integer(SHR_KIND_IN) :: ymd,tod,ymd0,tod0 ! used to compute time of time-sample + integer(SHR_KIND_IN) :: ldt ! local dt as needed + integer(SHR_KIND_I8) :: ldt8 ! local dt as needed in i8 + integer(SHR_KIND_I8) :: dtsec ! delta time from timeint + real(SHR_KIND_R8),pointer :: cosz(:) ! cos(zenith angle) + + !----- formats ----- + character(*),parameter :: subName = "(shr_tInterp_getAvgCosz) " + character(*),parameter :: F00 = "('(shr_tInterp_getAvgCosz) ',8a)" + +!------------------------------------------------------------------------------- +! Computes time avg cosz over interval [LB,UB] +!------------------------------------------------------------------------------- + + lsize = size(lonr) + allocate(cosz(lsize)) + if (lsize < 1 .or. size(latr) /= lsize .or. size(tavCosz) /= lsize) then + call shr_sys_abort(subname//' ERROR: lon lat tavCosz sizes disagree') + endif + + ldt = dt + + !--- get LB & UB dates --- + call shr_cal_timeSet(reday1,ymd1,tod1,calendar) + call shr_cal_timeSet(reday2,ymd2,tod2,calendar) + if (reday1 > reday2) call shr_sys_abort(subname//'ERROR: lower-bound > upper-bound') + + timeint = reday2-reday1 + call ESMF_TimeIntervalGet(timeint,s_i8=dtsec) + ldt8 = ldt + if (mod(dtsec,ldt8) /= 0) then + ldt8 = (dtsec)/((dtsec)/ldt8+1) + ldt = ldt8 + endif + + !--- compute time average --- + tavCosz = 0.0_SHR_KIND_R8 ! initialize partial sum + n = 0 ! dt weighted average in t-avg + reday = reday1 ! mid [LB,UB] interval t-step starts at LB + ymd = ymd1 + tod = tod1 + do while( reday < reday2) ! mid-interval t-steps thru interval [LB,UB] + + !--- advance to next time in [LB,UB] --- + ymd0 = ymd + tod0 = tod + reday0 = reday + call shr_cal_advDateInt(ldt,'seconds',ymd0,tod0,ymd,tod,calendar) + call shr_cal_timeSet(reday,ymd,tod,calendar) + + if (reday > reday2) then + ymd = ymd2 + tod = tod2 + timeint = reday2-reday0 + call ESMF_TimeIntervalGet(timeint,s_i8=dtsec) + ldt = dtsec + endif + + !--- get next cosz value for t-avg --- + call shr_tInterp_getCosz(cosz,lonr,latr,ymd,tod,eccen,mvelpp,lambm0,obliqr,calendar) + n = n + ldt + tavCosz = tavCosz + cosz*real(ldt,SHR_KIND_R8) ! add to partial sum + + end do + tavCosz = tavCosz/real(n,SHR_KIND_R8) ! form t-avg + + deallocate( cosz ) + +end subroutine shr_tInterp_getAvgCosz + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_getCosz -- calculate cosine(solar-zenith angle). +! +! !DESCRIPTION: +! +! Calculate the cos(solar-zenith angle). +! +! !REVISION HISTORY: +! 2010-Apr - B. Kauffman - returns cosz +! 2009-Oct - T. Craig - added +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_getCosz(cosz,lonr,latr,ymd,tod,eccen,mvelpp,lambm0,obliqr,calendar) + + implicit none + +! !USES: + +! !INPUT/OUTPUT PARAMETERS: + + real(SHR_KIND_R8) ,intent(out) :: cosz(:) ! cos(zenith angle) + real(SHR_KIND_R8) ,intent(in) :: latr(:) ! latitude + real(SHR_KIND_R8) ,intent(in) :: lonr(:) ! longitude + integer(SHR_KIND_IN),intent(in) :: ymd,tod ! date of interest + real(SHR_KIND_R8) ,intent(in) :: eccen ! orb param + real(SHR_KIND_R8) ,intent(in) :: mvelpp ! orb param + real(SHR_KIND_R8) ,intent(in) :: lambm0 ! orb param + real(SHR_KIND_R8) ,intent(in) :: obliqr ! orb param + character(*), intent(in) :: calendar ! calendar type + +!EOP + + !----- local ------ + integer(SHR_KIND_IN) :: n + integer(SHR_KIND_IN) :: lsize + real(SHR_KIND_R8) :: calday ! julian days + real(SHR_KIND_R8) :: declin,eccf ! orb params + + real(SHR_KIND_R8),parameter :: solZenMin = 0.001_SHR_KIND_R8 ! min solar zenith angle + + !----- formats ----- + character(*),parameter :: subName = "(shr_tInterp_getCosz) " + character(*),parameter :: F00 = "('(shr_tInterp_getCosz) ',8a)" + +!------------------------------------------------------------------------------- +! Returns cos(zenith angle) +!------------------------------------------------------------------------------- + + lsize = size(lonr) + if (lsize < 1 .or. size(latr) /= lsize .or. size(cosz) /= lsize) then + call shr_sys_abort(subname//' ERROR: lon lat cosz sizes disagree') + endif + + call shr_cal_date2julian(ymd,tod,calday,calendar) + call shr_orb_decl( calday, eccen, mvelpp, lambm0, obliqr, declin, eccf) + do n = 1,lsize + cosz(n) = max(solZenMin, shr_orb_cosz( calday, latr(n), lonr(n), declin )) + end do + +end subroutine shr_tInterp_getCosz + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_setAbort -- Set local shr_tInterp abort flag +! +! !DESCRIPTION: +! Set local shr_tInterp abort flag, true = abort, false = print and continue +! \newline +! call shr\_tInterp\_setAbort(.false.) +! +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_setAbort(flag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + logical,intent(in) :: flag + +!EOP + + !--- formats --- + character(*),parameter :: subName = "(shr_tInterp_setAbort) " + character(*),parameter :: F00 = "('(shr_tInterp_setAbort) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + doabort = flag + +end subroutine shr_tInterp_setAbort + +!=============================================================================== +!XXBOP =========================================================================== +! +! !IROUTINE: shr_tInterp_abort -- local interface for abort +! +! !DESCRIPTION: +! Local interface for shr\_tInterp abort calls +! \newline +! call shr\_tInterp\_abort(subName//' ERROR illegal option') +! +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_abort(string) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + character(*),optional,intent(in) :: string + +!XXEOP + + !--- formats --- + character(SHR_KIND_CL) :: lstring + character(*),parameter :: subName = "(shr_tInterp_abort) " + character(*),parameter :: F00 = "('(shr_tInterp_abort) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + lstring = '' + if (present(string)) lstring = string + + if (doabort) then + call shr_sys_abort(lstring) + else + write(s_logunit,F00) trim(lstring) + endif + +end subroutine shr_tInterp_abort + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_getDebug -- Get local shr_tInterp debug level +! +! !DESCRIPTION: +! Get local shr_tInterp debug level, 0 = production +! \newline +! call shr\_tInterp\_getDebug(level) +! +! !REVISION HISTORY: +! 2005-Jun-14 - B. Kauffman +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_getDebug(level) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(out) :: level + +!EOP + + !--- formats --- + character(*),parameter :: subName = "(shr_tInterp_getDebug) " + character(*),parameter :: F00 = "('(shr_tInterp_getDebug) ',a) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + level = debug + +end subroutine shr_tInterp_getDebug + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_tInterp_setDebug -- Set local shr_tInterp debug level +! +! !DESCRIPTION: +! Set local shr_tInterp debug level, 0 = production +! \newline +! call shr\_tInterp\_setDebug(2) +! +! !REVISION HISTORY: +! 2005-Apr-10 - T. Craig - first prototype +! +! !INTERFACE: ------------------------------------------------------------------ + +subroutine shr_tInterp_setDebug(iflag) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer,intent(in) :: iflag + +!EOP + + !--- formats --- + character(*),parameter :: subName = "(shr_tInterp_setDebug) " + character(*),parameter :: F01 = "('(shr_tInterp_setDebug) ',a,i3) " + +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + + debug = iflag + if (debug>0 .and. s_loglev > 0) write(s_logunit,F01) "DEBUG: level changed to ",debug + +end subroutine shr_tInterp_setDebug + +!=============================================================================== +!=============================================================================== + +end module shr_tInterp_mod diff --git a/share/csm_share/shr/shr_timer_mod.F90 b/share/csm_share/shr/shr_timer_mod.F90 new file mode 100644 index 000000000000..0fd22b119a5a --- /dev/null +++ b/share/csm_share/shr/shr_timer_mod.F90 @@ -0,0 +1,397 @@ +!=============================================================================== +! SVN $Id: shr_timer_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_timer_mod.F90 $ +!=============================================================================== + +module shr_timer_mod + + !---------------------------------------------------------------------------- + ! + ! routines that support multiple CPU timers via F90 intrinsics + ! + ! Note: + ! o if an operation is requested on an invalid timer number n + ! then nothing is done in a routine + ! o if more than max_timers are requested, + ! then timer n=max_timers is "overloaded" and becomes invalid/undefined + ! + ! * cpp if-defs were introduced in 2005 to work-around a bug in the ORNL Cray + ! X1 F90 intrinsic system_clock() function -- ideally this Cray bug would be + ! fixed and cpp if-defs would be unnecessary and removed. + ! + ! !REVISION HISTORY: + ! 2005-??-?? - added workaround for Cray F90 bug, mods by Cray/ORNL + ! 2000-??-?? - 1st version by B. Kauffman + !---------------------------------------------------------------------------- + + use shr_kind_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + + private ! restricted access + + public :: shr_timer_init + public :: shr_timer_get + public :: shr_timer_start + public :: shr_timer_stop + public :: shr_timer_print + public :: shr_timer_print_all + public :: shr_timer_check + public :: shr_timer_check_all + public :: shr_timer_zero + public :: shr_timer_zero_all + public :: shr_timer_free + public :: shr_timer_free_all + public :: shr_timer_sleep + + integer(SHR_KIND_IN),parameter :: stat_free = 0 ! timer status constants + integer(SHR_KIND_IN),parameter :: stat_inuse = 1 + integer(SHR_KIND_IN),parameter :: stat_started = 2 + integer(SHR_KIND_IN),parameter :: stat_stopped = 3 + integer(SHR_KIND_IN),parameter :: max_timers = 200 ! max number of timers + + integer(SHR_KIND_IN) :: status (max_timers) ! status of each timer + integer(SHR_KIND_IN) :: cycles1(max_timers) ! cycle number at timer start + integer(SHR_KIND_IN) :: cycles2(max_timers) ! cycle number at timer stop + integer(SHR_KIND_IN) :: cycles_max = -1 ! max cycles before wrapping + character (len=80) :: name (max_timers) ! name assigned to each timer + real (SHR_KIND_R8) :: dt (max_timers) ! accumulated time + integer(SHR_KIND_IN) :: calls (max_timers) ! # of samples in accumulation + real (SHR_KIND_R8) :: clock_rate ! clock_rate: seconds per cycle + + save + +!=============================================================================== + contains +!=============================================================================== + +subroutine shr_timer_init + + !----- local ----- + integer(SHR_KIND_IN) :: cycles ! count rate return by system clock + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_init) ',a,i5)" + +!------------------------------------------------------------------------------- +! This routine initializes: +! 1) values in all timer array locations +! 2) machine parameters necessary for computing cpu time from F90 intrinsics. +! F90 intrinsic: system_clock(count_rate=cycles, count_max=cycles_max) +!------------------------------------------------------------------------------- + + call shr_timer_free_all + + call system_clock(count_rate=cycles, count_max=cycles_max) + + if (cycles /= 0) then + clock_rate = 1.0_SHR_KIND_R8/real(cycles,SHR_KIND_R8) + else + clock_rate = 0._SHR_KIND_R8 + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: no system clock available' + endif + +end subroutine shr_timer_init + +!=============================================================================== + +subroutine shr_timer_get(n, str) + + !----- arguments ----- + integer(SHR_KIND_IN),intent(out) :: n ! timer number + character (*) ,intent( in) :: str ! text string with timer name + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_get) ',a,i5)" + +!----------------------------------------------------------------------- +! search for next free timer +!----------------------------------------------------------------------- + + do n=1,max_timers + if (status(n) == stat_free) then + status(n) = stat_inuse + name (n) = str + calls (n) = 0 + return + endif + end do + + n=max_timers + name (n) = "" + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: exceeded maximum number of timers' + +end subroutine shr_timer_get + +!=============================================================================== + +subroutine shr_timer_start(n) + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: n ! timer number + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_start) ',a,i5)" + +!----------------------------------------------------------------------- +! This routine starts a given timer. +!----------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + if (status(n) == stat_started) call shr_timer_stop(n) + + status(n) = stat_started + call system_clock(count=cycles1(n)) + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_start + +!=============================================================================== + +subroutine shr_timer_stop(n) + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: n ! timer number + + !----- local ----- + real (SHR_KIND_R8) :: elapse ! elapsed time returned by system counter + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_stop) ',a,i5)" + +!------------------------------------------------------------------------------- +! This routine stops a given timer, checks for cycle wrapping, computes the +! elapsed time, and accumulates the elapsed time in the dt(n) array +!------------------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + if ( status(n) == stat_started) then + call system_clock(count=cycles2(n)) + if (cycles2(n) >= cycles1(n)) then + dt(n) = dt(n) + clock_rate*(cycles2(n) - cycles1(n)) + else + dt(n) = dt(n) + clock_rate*(cycles_max + cycles2(n) - cycles1(n)) + endif + calls (n) = calls(n) + 1 + status(n) = stat_stopped + end if + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_stop + +!=============================================================================== + +subroutine shr_timer_print(n) + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: n ! timer number + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_print) ',a,i5)" + character(len=*),parameter :: F01 = "('(shr_timer_print) timer',i3,& + & ':',i8,' calls,',f10.3,'s, id: ',a)" +!------------------------------------------------------------------------------- +! prints the accumulated time for a given timer +!------------------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + if (status(n) == stat_started) then + call shr_timer_stop(n) + if (s_loglev > 0) write(s_logunit,F01) n,calls(n),dt(n),trim(name(n)) + call shr_timer_start(n) + else + if (s_loglev > 0) write(s_logunit,F01) n,calls(n),dt(n),trim(name(n)) + endif + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_print + +!=============================================================================== + +subroutine shr_timer_print_all + + !----- local ----- + integer(SHR_KIND_IN) :: n + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_print_all) ',a,i5)" + +!------------------------------------------------------------------------------- +! prints accumulated time for all timers in use +!------------------------------------------------------------------------------- + + if (s_loglev > 0) write(s_logunit,F00) 'print all timing info:' + + do n=1,max_timers + if (status(n) /= stat_free) call shr_timer_print(n) + end do + +end subroutine shr_timer_print_all + +!=============================================================================== + +subroutine shr_timer_zero(n) + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: n ! timer number + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_zero) ',a,i5)" + +!------------------------------------------------------------------------------- +! This routine resets a given timer. +!------------------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + dt(n) = 0.0_SHR_KIND_R8 + calls(n) = 0 + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_zero + +!=============================================================================== + +subroutine shr_timer_zero_all + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_zero_all) ',a,i5)" + +!------------------------------------------------------------------------------- +! This routine resets all timers. +!------------------------------------------------------------------------------- + + dt = 0.0_SHR_KIND_R8 + calls = 0 + +end subroutine shr_timer_zero_all + +!=============================================================================== + +subroutine shr_timer_check(n) + + !----- arguments ----- + integer(SHR_KIND_IN), intent(in) :: n ! timer number + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_check) ',a,i5)" + +!------------------------------------------------------------------------------- +! This routine checks a given timer. This is primarily used to +! periodically accumulate time in the timer to prevent timer cycles +! from wrapping around max_cycles. +!------------------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + if (status(n) == stat_started) then + call shr_timer_stop (n) + call shr_timer_start(n) + endif + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_check + +!=============================================================================== + +subroutine shr_timer_check_all + + !----- local ----- + integer(SHR_KIND_IN) :: n + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_check_all) ',a,i5)" + +!------------------------------------------------------------------------------- +! Call shr_timer_check for all timers in use +!------------------------------------------------------------------------------- + + do n=1,max_timers + if (status(n) == stat_started) then + call shr_timer_stop (n) + call shr_timer_start(n) + endif + end do + +end subroutine shr_timer_check_all + +!=============================================================================== + +subroutine shr_timer_free(n) + + !----- arguments ----- + integer(SHR_KIND_IN),intent(in) :: n ! timer number + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_free) ',a,i5)" + +!----------------------------------------------------------------------- +! initialize/free all timer array values +!----------------------------------------------------------------------- + + if ( n>0 .and. n<=max_timers) then + status (n) = stat_free + name (n) = "" + dt (n) = 0.0_SHR_KIND_R8 + cycles1(n) = 0 + cycles2(n) = 0 + else + if (s_loglev > 0) write(s_logunit,F00) 'ERROR: invalid timer number: ',n + end if + +end subroutine shr_timer_free + +!=============================================================================== + +subroutine shr_timer_free_all + + !----- local ----- + integer(SHR_KIND_IN) :: n + + !----- i/o formats ----- + character(len=*),parameter :: F00 = "('(shr_timer_free_all) ',a,i5)" + +!------------------------------------------------------------------------------- +! initialize/free all timer array values +!------------------------------------------------------------------------------- + + do n=1,max_timers + call shr_timer_free(n) + end do + +end subroutine shr_timer_free_all + +!=============================================================================== + +subroutine shr_timer_sleep(sec) + + use shr_sys_mod ! share system calls (namely, shr_sys_sleep) + + !----- local ----- + real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep + +!------------------------------------------------------------------------------- +! Sleep for approximately sec seconds +! +! Note: sleep is typically a system call, hence it is implemented in +! shr_sys_mod, although it probably would only be used in a timing +! context, which is why there is a shr_timer_* wrapper provided here. +!------------------------------------------------------------------------------- + + call shr_sys_sleep(sec) + +end subroutine shr_timer_sleep + +!=============================================================================== +end module shr_timer_mod +!=============================================================================== diff --git a/share/csm_share/shr/shr_vmath_mod.F90 b/share/csm_share/shr/shr_vmath_mod.F90 new file mode 100644 index 000000000000..e41f1bf3a97a --- /dev/null +++ b/share/csm_share/shr/shr_vmath_mod.F90 @@ -0,0 +1,233 @@ +!=============================================================================== +! SVN $Id: shr_vmath_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_vmath_mod.F90 $ +!=============================================================================== +! PURPOSE: +! provides a uniform, platform-independent API for vector math functions +!=============================================================================== + +module shr_vmath_mod + + !---------------------------------------------------------------------------- + ! routines that evaluate various math functions for vector arguments + ! intended to provide platform independent access to vendor optimized code + !---------------------------------------------------------------------------- + + use shr_kind_mod + use shr_log_mod, only: s_loglev => shr_log_Level + use shr_log_mod, only: s_logunit => shr_log_Unit + + implicit none + + private + public :: shr_vmath_sqrt, & + shr_vmath_exp, shr_vmath_log, & + shr_vmath_sin, shr_vmath_cos, & + shr_vmath_rsqrt, shr_vmath_div + + contains + +!=============================================================================== + +subroutine shr_vmath_sqrt(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: sqrt for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- +#ifndef NO_SHR_VMATH +#if (defined CPRINTEL) + call vdsqrt(n, X, Y) + return +#endif + +#if (defined AIX) + call vsqrt(Y, X, n) + return +#endif + +#endif + Y = sqrt(X) + return + +end subroutine shr_vmath_sqrt + +!=============================================================================== + +subroutine shr_vmath_rsqrt(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: reciprical sqrt for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- + +#ifndef NO_SHR_VMATH +#if (defined AIX) + call vrsqrt(Y, X, n) + return +#endif +!#ifdef CPRINTEL +! Does not pass unit tests +! real (SHR_KIND_R8) :: RX(n) ! +! call vdsqrt(n, X, RX) +! call vddiv(n, 1.0_SHR_KIND_R8,RX, Y) +! return +!#endif +#endif + Y = 1.0_SHR_KIND_R8/sqrt(X) + + +end subroutine shr_vmath_rsqrt + +!=============================================================================== + +subroutine shr_vmath_exp(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: exp for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- + +#ifndef NO_SHR_VMATH +#if (defined CPRINTEL) + call vdexp(n, X, Y) + return +#endif +#if (defined AIX) + call vexp(Y, X, n) + return +#endif +#endif + + Y = exp(X) + return + +end subroutine shr_vmath_exp + +!=============================================================================== + +subroutine shr_vmath_div(X, Y, Z, n) + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(in) :: Y(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Z(n) ! output vector argument + integer :: i +#ifndef NO_SHR_VMATH +#if (defined CPRINTEL) + call vddiv(n, X, Y, Z) + return +#endif + +#if (defined AIX) + call vdiv(Z,X,Y,n) + return +#endif +#endif + + do i=1,n + Z(i) = X(i)/Y(i) + enddo + return + end subroutine shr_vmath_div + +!=============================================================================== + +subroutine shr_vmath_log(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: log for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- +#ifndef NO_SHR_VMATH +#if (defined AIX) + call vlog(Y, X, n) + return +#endif +#if (defined CPRINTEL) + call vdln(n, X, Y) + return +#endif +#endif + Y = log(X) + return + + +end subroutine shr_vmath_log + +!=============================================================================== + +subroutine shr_vmath_sin(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: sin for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- + +#ifndef NO_SHR_VMATH +#if (defined AIX) + call vsin(Y, X, n) + return +#endif + +#if (defined CPRINTEL) + call vdsin(n, X, Y) + return +#endif +#endif + Y = sin(X) + return + +end subroutine shr_vmath_sin + +!=============================================================================== + +subroutine shr_vmath_cos(X, Y, n) + + !----- arguments --- + integer(SHR_KIND_IN),intent(in) :: n ! vector length + real (SHR_KIND_R8),intent(in) :: X(n) ! input vector argument + real (SHR_KIND_R8),intent(out) :: Y(n) ! output vector argument + +!------------------------------------------------------------------------------- +! PURPOSE: cos for vector arguments, optimized on different platforms +!------------------------------------------------------------------------------- + +#ifndef NO_SHR_VMATH +#if (defined AIX) + call vcos(Y, X, n) + return +#endif +#if (defined CPRINTEL) + call vdcos(n, X, Y) + return +#endif +#endif + Y = cos(X) + return + +end subroutine shr_vmath_cos + +!=============================================================================== + +end module shr_vmath_mod diff --git a/share/csm_share/shr/shr_wv_sat_mod.F90 b/share/csm_share/shr/shr_wv_sat_mod.F90 new file mode 100644 index 000000000000..0ed7646aca57 --- /dev/null +++ b/share/csm_share/shr/shr_wv_sat_mod.F90 @@ -0,0 +1,1068 @@ +module shr_wv_sat_mod + +! This portable module contains all CAM methods for estimating the saturation +! vapor pressure of water. +! +! wv_saturation provides CAM-specific interfaces and utilities based on these +! formulae. +! +! Typical usage of this module: +! +! Init: +! call shr_wv_sat_init(, errstring) +! +! Get scheme index from a name string: +! scheme_idx = shr_wv_sat_get_scheme_idx("GoffGratch") +! if (.not. shr_wv_sat_valid_idx(scheme_idx)) +! +! Get pressures: +! es = shr_wv_sat_svp_liquid(t, scheme_idx) +! es = shr_wv_sat_svp_ice(t, scheme_idx) +! +! Use ice/water transition range: +! es = shr_wv_sat_svp_mixed(t, scheme_idx) +! +! Note that elemental functions cannot be pointed to, nor passed as +! arguments. If you need to do either, it is recommended to wrap the function so +! that it can be given an explicit (non-elemental) interface. +! +! Since usually only one scheme is used at a time, the scheme index is an +! optional argument. If omitted a default scheme will be used, which is +! initially the Goff & Gratch scheme. To change the default, you can make a call +! like this: +! +! call shr_wv_sat_set_default("MurphyKoop") +! +! This module has the ability to store lookup tables to cache values. To do so, +! create a ShrWVSatTableSpec instance for water and ice with the desired size +! and range, then call shr_wv_sat_make_tables like so: +! +! type(ShrWVSatTableSpec) :: liquid_spec, ice_spec, mixed_spec +! +! liquid_spec = ShrWVSatTableSpec(151, tmelt-50._rk, 1._rk) +! ice_spec = ShrWVSatTableSpec(106, tmelt-100._rk, 1._rk) +! mixed_spec = ShrWVSatTableSpec(21, tmelt-20._rk, 1._rk) +! call shr_wv_sat_make_tables(liquid_spec, ice_spec, mixed_spec) +! +! Currently, this module only supports making tables for the default scheme, and +! shr_wv_sat_make_tables must be invoked again to produce new tables if the default +! is changed. +! +! Once tables are produced, all uses of the default scheme will attempt to +! linearly interpolate values from the lookup tables. If a temperature is +! outside the table bounds, the original scheme will be invoked as if no table +! was present. That is, the tables will *not* be extrapolated. +! +! Threading note: The physical constants, the current default, and the lookup +! tables are stored in global, thread-shared variables. Therefore the following +! procedures are not thread-safe: +! +! - shr_wv_sat_init +! - shr_wv_sat_final +! - shr_wv_sat_set_default +! - shr_wv_sat_make_tables +! +! If a multi-threaded application calls any of these procedures, the user is +! responsible for ensuring that each call is perfomed by only one thread, and +! that synchronization is performed to before and after each of these calls. +! +! All other public routines are thread-safe. + +#ifdef SHR_WV_SAT_USE_CLUBB_KIND +! If running within CLUBB, use the same precision as CLUBB. +use clubb_precision, only: core_rkind +#endif + +implicit none +private +save + +! Initialize/finalize module and pick schemes +public shr_wv_sat_init +public shr_wv_sat_final +public shr_wv_sat_get_scheme_idx +public shr_wv_sat_valid_idx +public shr_wv_sat_set_default + +! Manage lookup tables +public ShrWVSatTableSpec +public shr_wv_sat_make_tables + +! Basic SVP calculations +public shr_wv_sat_svp_liquid +public shr_wv_sat_svp_ice +public shr_wv_sat_svp_mixed + +! pressure -> humidity conversion +public shr_wv_sat_svp_to_qsat + +! pressure -> mass mixing ratio conversion +public shr_wv_sat_svp_to_qmmr + +! Combined qsat operations +public shr_wv_sat_qsat_liquid +public shr_wv_sat_qsat_ice +public shr_wv_sat_qsat_mixed + +#ifdef SHR_WV_SAT_USE_CLUBB_KIND +integer, parameter :: rk = core_rkind +#else +! Double precision +integer, parameter :: rk = selected_real_kind(12) +#endif + +real(rk) :: tmelt ! Melting point of water at 1 atm (K) +real(rk) :: h2otrip ! Triple point temperature of water (K) + +real(rk) :: ttrice ! Ice-water transition range + +real(rk) :: epsilo ! Ice-water transition range +real(rk) :: omeps ! 1._rk - epsilo + +! Indices representing individual schemes +integer, parameter :: Invalid_idx = -1 +! Skip 0; this was the old implementation of Goff & Gratch. +integer, parameter :: GoffGratch_idx = 1 +integer, parameter :: MurphyKoop_idx = 2 +integer, parameter :: Bolton_idx = 3 +integer, parameter :: Flatau_idx = 4 + +! Index representing the current default scheme. +integer, parameter :: initial_default_idx = GoffGratch_idx +integer :: default_idx = initial_default_idx + +! Type to represent a table specification. +type ShrWVSatTableSpec + integer :: table_size + real(rk) :: minimum + real(rk) :: spacing +end type ShrWVSatTableSpec + +type(ShrWVSatTableSpec) :: liquid_table_spec +real(rk), allocatable :: liquid_table(:) + +type(ShrWVSatTableSpec) :: ice_table_spec +real(rk), allocatable :: ice_table(:) + +type(ShrWVSatTableSpec) :: mixed_table_spec +real(rk), allocatable :: mixed_table(:) + +interface shr_wv_sat_svp_liquid + module procedure shr_wv_sat_svp_liquid + module procedure shr_wv_sat_svp_liquid_vec +end interface shr_wv_sat_svp_liquid + +interface shr_wv_sat_svp_ice + module procedure shr_wv_sat_svp_ice + module procedure shr_wv_sat_svp_ice_vec +end interface shr_wv_sat_svp_ice + +interface shr_wv_sat_svp_mixed + module procedure shr_wv_sat_svp_mixed + module procedure shr_wv_sat_svp_mixed_vec +end interface shr_wv_sat_svp_mixed + +interface shr_wv_sat_svp_to_qsat + module procedure shr_wv_sat_svp_to_qsat + module procedure shr_wv_sat_svp_to_qsat_vec +end interface shr_wv_sat_svp_to_qsat + +interface shr_wv_sat_svp_to_qmmr + module procedure shr_wv_sat_svp_to_qmmr + module procedure shr_wv_sat_svp_to_qmmr_vec +end interface shr_wv_sat_svp_to_qmmr + +interface shr_wv_sat_qsat_liquid + module procedure shr_wv_sat_qsat_liquid + module procedure shr_wv_sat_qsat_liquid_vec +end interface shr_wv_sat_qsat_liquid + +interface shr_wv_sat_qsat_ice + module procedure shr_wv_sat_qsat_ice + module procedure shr_wv_sat_qsat_ice_vec +end interface shr_wv_sat_qsat_ice + +interface shr_wv_sat_qsat_mixed + module procedure shr_wv_sat_qsat_mixed + module procedure shr_wv_sat_qsat_mixed_vec +end interface shr_wv_sat_qsat_mixed + +contains + +!--------------------------------------------------------------------- +! ADMINISTRATIVE FUNCTIONS +!--------------------------------------------------------------------- + +! Get physical constants +subroutine shr_wv_sat_init(tmelt_in, h2otrip_in, ttrice_in, epsilo_in, & + errstring) + real(rk), intent(in) :: tmelt_in + real(rk), intent(in) :: h2otrip_in + real(rk), intent(in) :: ttrice_in + real(rk), intent(in) :: epsilo_in + character(len=*), intent(out) :: errstring + + errstring = ' ' + + if (ttrice_in < 0._rk) then + write(errstring,*) 'shr_wv_sat_init: ERROR: ', & + ttrice_in,' was input for ttrice, but negative range is invalid.' + return + end if + + tmelt = tmelt_in + h2otrip = h2otrip_in + ttrice = ttrice_in + epsilo = epsilo_in + + omeps = 1._rk - epsilo + +end subroutine shr_wv_sat_init + +! Reset module data to the original state (primarily for testing purposes). +! It doesn't seem worthwhile to reset the constants, so just deal with options +! and dynamic memory here. +subroutine shr_wv_sat_final() + + default_idx = initial_default_idx + + if (allocated(liquid_table)) deallocate(liquid_table) + if (allocated(ice_table)) deallocate(ice_table) + if (allocated(mixed_table)) deallocate(mixed_table) + +end subroutine shr_wv_sat_final + +! Look up index by name. +pure function shr_wv_sat_get_scheme_idx(name) result(idx) + character(len=*), intent(in) :: name + integer :: idx + + ! Several names are given to most methods in order to support the names that + ! CLUBB accepts. + select case (name) + case("GoffGratch", "gfdl", "GFDL") + idx = GoffGratch_idx + case("MurphyKoop") + idx = MurphyKoop_idx + case("Bolton", "bolton") + idx = Bolton_idx + case("Flatau", "flatau") + idx = Flatau_idx + case default + idx = Invalid_idx + end select + +end function shr_wv_sat_get_scheme_idx + +! Check validity of an index from the above routine. +pure function shr_wv_sat_valid_idx(idx) result(status) + integer, intent(in) :: idx + logical :: status + + status = (idx /= Invalid_idx) + +end function shr_wv_sat_valid_idx + +! Set default scheme (otherwise, Goff & Gratch is default) +! Returns a logical representing success (.true.) or +! failure (.false.). +function shr_wv_sat_set_default(name) result(status) + character(len=*), intent(in) :: name + logical :: status + + ! Don't want to overwrite valid default with invalid, + ! so assign to temporary and check it first. + integer :: tmp_idx + + tmp_idx = shr_wv_sat_get_scheme_idx(name) + + status = shr_wv_sat_valid_idx(tmp_idx) + + ! If we have changed the default, deallocated the tables as well as setting + ! the new default. + if (status .and. tmp_idx /= default_idx) then + if (allocated(liquid_table)) deallocate(liquid_table) + if (allocated(ice_table)) deallocate(ice_table) + if (allocated(mixed_table)) deallocate(mixed_table) + default_idx = tmp_idx + end if + +end function shr_wv_sat_set_default + +subroutine shr_wv_sat_make_tables(liquid_spec_in, ice_spec_in, mixed_spec_in) + type(ShrWVSatTableSpec), intent(in), optional :: liquid_spec_in + type(ShrWVSatTableSpec), intent(in), optional :: ice_spec_in + type(ShrWVSatTableSpec), intent(in), optional :: mixed_spec_in + + if (present(liquid_spec_in)) then + liquid_table_spec = liquid_spec_in + call shr_wv_sat_make_one_table(liquid_table_spec, shr_wv_sat_svp_liquid_no_table, & + liquid_table) + end if + + if (present(ice_spec_in)) then + ice_table_spec = ice_spec_in + call shr_wv_sat_make_one_table(ice_table_spec, shr_wv_sat_svp_ice_no_table, & + ice_table) + end if + + if (present(mixed_spec_in)) then + mixed_table_spec = mixed_spec_in + call shr_wv_sat_make_one_table(mixed_table_spec, shr_wv_sat_svp_mixed_no_table, & + mixed_table) + end if + +end subroutine shr_wv_sat_make_tables + +! Table-generating generic function (would be simpler with an object-oriented +! design, but we want this code to be runnable on compilers with poor Fortran +! 2003 support). This means we can't attach function pointers or methods to +! derived types. +subroutine shr_wv_sat_make_one_table(table_spec, svp_function, table) + type(ShrWVSatTableSpec), intent(in) :: table_spec + interface + function svp_function(t, idx) result(es) + import :: rk + real(rk), intent(in) :: t + integer, intent(in) :: idx + real(rk) :: es + end function svp_function + end interface + real(rk), intent(out), allocatable :: table(:) + + integer :: i + + allocate(table(table_spec%table_size)) + + do i = 1, table_spec%table_size + table(i) = svp_function( & + table_spec%minimum + table_spec%spacing*real(i-1, rk), & + default_idx) + end do + +end subroutine shr_wv_sat_make_one_table + +!--------------------------------------------------------------------- +! UTILITIES +!--------------------------------------------------------------------- + +! Get saturation specific humidity given pressure and SVP. +! Specific humidity is limited to the range 0-1. +elemental function shr_wv_sat_svp_to_qsat(es, p) result(qs) + + real(rk), intent(in) :: es ! SVP + real(rk), intent(in) :: p ! Current pressure. + real(rk) :: qs + + ! If pressure is less than SVP, set qs to maximum of 1. + if ( (p - es) <= 0._rk ) then + qs = 1.0_rk + else + qs = epsilo*es / (p - omeps*es) + end if + +end function shr_wv_sat_svp_to_qsat + +pure function shr_wv_sat_svp_to_qsat_vec(n, es, p) result(qs) + + integer, intent(in) :: n ! Size of input arrays + real(rk), intent(in) :: es(n) ! SVP + real(rk), intent(in) :: p(n) ! Current pressure + real(rk) :: qs(n) + + integer :: i + + ! If pressure is less than SVP, set qs to maximum of 1. + do i = 1, n + if ( (p(i) - es(i)) <= 0._rk ) then + qs(i) = 1.0_rk + else + qs(i) = epsilo*es(i) / (p(i) - omeps*es(i)) + end if + end do + +end function shr_wv_sat_svp_to_qsat_vec + +! Get saturation mass mixing ratio (over dry air) given pressure and SVP. +! Output is limited to the range 0-epsilo. +elemental function shr_wv_sat_svp_to_qmmr(es, p) result(qs) + + real(rk), intent(in) :: es ! SVP + real(rk), intent(in) :: p ! Current pressure + real(rk) :: qs + + ! If pressure is less than SVP, set qs to maximum of 1. + if ( (p - es) <= es ) then + qs = epsilo + else + qs = epsilo*es / (p - es) + end if + +end function shr_wv_sat_svp_to_qmmr + +pure function shr_wv_sat_svp_to_qmmr_vec(n, es, p) result(qs) + + integer, intent(in) :: n ! Size of input arrays + real(rk), intent(in) :: es(n) ! SVP + real(rk), intent(in) :: p(n) ! Current pressure + real(rk) :: qs(n) + + integer :: i + + ! If pressure is less than SVP, set qs to maximum of 1. + do i = 1, n + if ( (p(i) - es(i)) <= es(i) ) then + qs(i) = epsilo + else + qs(i) = epsilo*es(i) / (p(i) - es(i)) + end if + end do + +end function shr_wv_sat_svp_to_qmmr_vec + +elemental subroutine shr_wv_sat_qsat_liquid(t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over water at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + real(rk), intent(in) :: t ! Temperature + real(rk), intent(in) :: p ! Pressure + ! Outputs + real(rk), intent(out) :: es ! Saturation vapor pressure + real(rk), intent(out) :: qs ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_liquid(t, idx) + + qs = shr_wv_sat_svp_to_qsat(es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_liquid + +pure subroutine shr_wv_sat_qsat_liquid_vec(n, t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over water at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + integer, intent(in) :: n ! Size of input arrays + real(rk), intent(in) :: t(n) ! Temperature + real(rk), intent(in) :: p(n) ! Pressure + ! Outputs + real(rk), intent(out) :: es(n) ! Saturation vapor pressure + real(rk), intent(out) :: qs(n) ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_liquid(n, t, idx) + + qs = shr_wv_sat_svp_to_qsat(n, es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_liquid_vec + +elemental subroutine shr_wv_sat_qsat_ice(t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over ice at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + real(rk), intent(in) :: t ! Temperature + real(rk), intent(in) :: p ! Pressure + ! Outputs + real(rk), intent(out) :: es ! Saturation vapor pressure + real(rk), intent(out) :: qs ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_ice(t, idx) + + qs = shr_wv_sat_svp_to_qsat(es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_ice + +pure subroutine shr_wv_sat_qsat_ice_vec(n, t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over ice at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + integer, intent(in) :: n ! Size of input arrays + real(rk), intent(in) :: t(n) ! Temperature + real(rk), intent(in) :: p(n) ! Pressure + ! Outputs + real(rk), intent(out) :: es(n) ! Saturation vapor pressure + real(rk), intent(out) :: qs(n) ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_ice(n, t, idx) + + qs = shr_wv_sat_svp_to_qsat(n, es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_ice_vec + +elemental subroutine shr_wv_sat_qsat_mixed(t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over ice at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + real(rk), intent(in) :: t ! Temperature + real(rk), intent(in) :: p ! Pressure + ! Outputs + real(rk), intent(out) :: es ! Saturation vapor pressure + real(rk), intent(out) :: qs ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_mixed(t, idx) + + qs = shr_wv_sat_svp_to_qsat(es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_mixed + +pure subroutine shr_wv_sat_qsat_mixed_vec(n, t, p, es, qs, idx) + !------------------------------------------------------------------! + ! Purpose: ! + ! Calculate SVP over ice at a given temperature, and then ! + ! calculate and return saturation specific humidity. ! + !------------------------------------------------------------------! + + ! Inputs + integer, intent(in) :: n ! Size of input arrays + real(rk), intent(in) :: t(n) ! Temperature + real(rk), intent(in) :: p(n) ! Pressure + ! Outputs + real(rk), intent(out) :: es(n) ! Saturation vapor pressure + real(rk), intent(out) :: qs(n) ! Saturation specific humidity + + integer, intent(in), optional :: idx ! Scheme index + + es = shr_wv_sat_svp_mixed(n, t, idx) + + qs = shr_wv_sat_svp_to_qsat(n, es, p) + + ! Ensures returned es is consistent with limiters on qs. + es = min(es, p) + +end subroutine shr_wv_sat_qsat_mixed_vec + +!--------------------------------------------------------------------- +! SVP INTERFACE FUNCTIONS +!--------------------------------------------------------------------- + +elemental function shr_wv_sat_svp_liquid(t, idx) result(es) + real(rk), intent(in) :: t + integer, intent(in), optional :: idx + real(rk) :: es + + integer :: use_idx + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(liquid_table)) then + es = lookup_svp_in_table(t, liquid_table_spec, liquid_table, & + shr_wv_sat_svp_liquid_no_table) + else + es = shr_wv_sat_svp_liquid_no_table(t, use_idx) + end if + +end function shr_wv_sat_svp_liquid + +pure function shr_wv_sat_svp_liquid_vec(n, t, idx) result(es) + integer, intent(in) :: n + real(rk), intent(in) :: t(n) + integer, intent(in), optional :: idx + real(rk) :: es(n) + + integer :: use_idx + integer :: i + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(liquid_table)) then + do i = 1, n + es(i) = lookup_svp_in_table(t(i), liquid_table_spec, liquid_table, & + shr_wv_sat_svp_liquid_no_table) + end do + else + do i = 1, n + es(i) = shr_wv_sat_svp_liquid_no_table(t(i), use_idx) + end do + end if + +end function shr_wv_sat_svp_liquid_vec + +pure function shr_wv_sat_svp_liquid_no_table(t, idx) result(es) + real(rk), intent(in) :: t + integer, intent(in) :: idx + real(rk) :: es + + select case (idx) + case(GoffGratch_idx) + es = GoffGratch_svp_liquid(t) + case(MurphyKoop_idx) + es = MurphyKoop_svp_liquid(t) + case(Bolton_idx) + es = Bolton_svp_liquid(t) + case (Flatau_idx) + es = Flatau_svp_liquid(t) + case default + ! Providing a correct index is an important precondition for these + ! functions. Since we don't have a way of signaling an error, produce an + ! obviously unreasonable answer. + es = -huge(1._rk) + end select + +end function shr_wv_sat_svp_liquid_no_table + +elemental function shr_wv_sat_svp_ice(t, idx) result(es) + real(rk), intent(in) :: t + integer, intent(in), optional :: idx + real(rk) :: es + + integer :: use_idx + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(ice_table)) then + es = lookup_svp_in_table(t, ice_table_spec, ice_table, & + shr_wv_sat_svp_ice_no_table) + else + es = shr_wv_sat_svp_ice_no_table(t, use_idx) + end if + +end function shr_wv_sat_svp_ice + +pure function shr_wv_sat_svp_ice_vec(n, t, idx) result(es) + integer, intent(in) :: n + real(rk), intent(in) :: t(n) + integer, intent(in), optional :: idx + real(rk) :: es(n) + + integer :: use_idx + integer :: i + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(ice_table)) then + do i = 1, n + es(i) = lookup_svp_in_table(t(i), ice_table_spec, ice_table, & + shr_wv_sat_svp_ice_no_table) + end do + else + do i = 1, n + es(i) = shr_wv_sat_svp_ice_no_table(t(i), use_idx) + end do + end if + +end function shr_wv_sat_svp_ice_vec + +pure function shr_wv_sat_svp_ice_no_table(t, idx) result(es) + real(rk), intent(in) :: t + integer, intent(in) :: idx + real(rk) :: es + + select case (idx) + case(GoffGratch_idx) + es = GoffGratch_svp_ice(t) + case(MurphyKoop_idx) + es = MurphyKoop_svp_ice(t) + case(Bolton_idx) + es = Bolton_svp_ice(t) + case (Flatau_idx) + es = Flatau_svp_ice(t) + case default + ! Providing a correct index is an important precondition for these + ! functions. Since we don't have a way of signaling an error, produce an + ! obviously unreasonable answer. + es = -huge(1._rk) + end select + +end function shr_wv_sat_svp_ice_no_table + +elemental function shr_wv_sat_svp_mixed(t, idx) result (es) + + real(rk), intent(in) :: t + integer, intent(in), optional :: idx + + real(rk) :: es + + integer :: use_idx + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(mixed_table)) then + es = lookup_svp_in_table(t, mixed_table_spec, mixed_table, & + shr_wv_sat_svp_mixed_no_table) + else + es = shr_wv_sat_svp_mixed_no_table(t, use_idx) + end if + +end function shr_wv_sat_svp_mixed + +pure function shr_wv_sat_svp_mixed_vec(n, t, idx) result (es) + integer, intent(in) :: n + real(rk), intent(in) :: t(n) + integer, intent(in), optional :: idx + + real(rk) :: es(n) + + integer :: use_idx + integer :: i + + if (present(idx)) then + use_idx = idx + else + use_idx = default_idx + end if + + if (use_idx == default_idx .and. allocated(mixed_table)) then + do i = 1, n + es(i) = lookup_svp_in_table(t(i), mixed_table_spec, mixed_table, & + shr_wv_sat_svp_mixed_no_table) + end do + else + es = shr_wv_sat_svp_mixed_no_table_vec(n, t, use_idx) + end if + +end function shr_wv_sat_svp_mixed_vec + +pure function shr_wv_sat_svp_mixed_no_table(t, idx) result (es) + + real(rk), intent(in) :: t + integer, intent(in) :: idx + + real(rk) :: es + + real(rk) :: esice ! Saturation vapor pressure over ice + real(rk) :: weight ! Intermediate scratch variable for es transition + +! +! Water +! + if (t >= (tmelt - ttrice)) then + es = shr_wv_sat_svp_liquid(t,idx) + else + es = 0.0_rk + end if + +! +! Ice +! + if (t < tmelt) then + + esice = shr_wv_sat_svp_ice(t,idx) + + if ( (tmelt - t) > ttrice ) then + weight = 1.0_rk + else + weight = (tmelt - t)/ttrice + end if + + es = weight*esice + (1.0_rk - weight)*es + end if + +end function shr_wv_sat_svp_mixed_no_table + +! The reason why we need a separate vector version for this function (but +! not the other "no_table" functions) is that even if the functions called +! are all inlined, we may still have a table lookup for the liquid/ice +! tables (rather than the mixed-phase one). That table lookup is not +! vectorizable, meaning that the above function can't vectorize. +! +! Cripes this is ugly, though. +pure function shr_wv_sat_svp_mixed_no_table_vec(n, t, idx) result (es) + + integer, intent(in) :: n + real(rk), intent(in) :: t(n) + integer, intent(in) :: idx + + real(rk) :: es(n) + + real(rk) :: esice ! Saturation vapor pressure over ice + real(rk) :: weight ! Intermediate scratch variable for es transition + + integer :: i + +! +! Water +! + if (idx == default_idx .and. allocated(liquid_table)) then + do i = 1, n + if (t(i) >= (tmelt - ttrice)) then + es(i) = lookup_svp_in_table(t(i), liquid_table_spec, liquid_table, & + shr_wv_sat_svp_liquid_no_table) + else + es(i) = 0.0_rk + end if + end do + else + do i = 1, n + if (t(i) >= (tmelt - ttrice)) then + es(i) = shr_wv_sat_svp_liquid_no_table(t(i), idx) + else + es(i) = 0.0_rk + end if + end do + end if + +! +! Ice +! + if (idx == default_idx .and. allocated(ice_table)) then + do i = 1, n + if (t(i) < tmelt) then + esice = lookup_svp_in_table(t(i), ice_table_spec, ice_table, & + shr_wv_sat_svp_ice_no_table) + + if ( (tmelt - t(i)) > ttrice ) then + weight = 1.0_rk + else + weight = (tmelt - t(i))/ttrice + end if + + es(i) = weight*esice + (1.0_rk - weight)*es(i) + end if + end do + else + do i = 1, n + if (t(i) < tmelt) then + esice = shr_wv_sat_svp_ice_no_table(t(i), idx) + + if ( (tmelt - t(i)) > ttrice ) then + weight = 1.0_rk + else + weight = (tmelt - t(i))/ttrice + end if + + es(i) = weight*esice + (1.0_rk - weight)*es(i) + end if + end do + end if + +end function shr_wv_sat_svp_mixed_no_table_vec + +!--------------------------------------------------------------------- +! SVP METHODS +!--------------------------------------------------------------------- + +! Use the lookup table +! Note that a function that takes a procedure argument can't be elemental, but +! it must be pure to be called from the elemental interfaces above. +recursive pure function lookup_svp_in_table(t, table_spec, table, fallback) & + result(es) + ! Temperature in Kelvin + real(rk), intent(in) :: t + ! Table range specification + type(ShrWVSatTableSpec), intent(in) :: table_spec + ! The table itself + real(rk), intent(in) :: table(table_spec%table_size) + ! Fallback used when we're outside the table bounds + interface + pure function fallback(t, idx) result(es) + import :: rk + real(rk), intent(in) :: t + integer, intent(in) :: idx + real(rk) :: es + end function fallback + end interface + ! SVP in Pa + real(rk) :: es + + integer :: idx + real(rk) :: residual + + residual = (t - table_spec%minimum)/table_spec%spacing + 1._rk + idx = int(residual) + ! Deal with the case where we're outside the table bounds. + if (idx < 1 .or. idx+1 > table_spec%table_size) then + es = fallback(t, default_idx) + return + end if + + ! Now we want the "residual" to be how far this temperature is past the + ! current index. + residual = residual - real(idx, rk) + + ! Just use linear interpolation. Some iterative methods might do better if we + ! used a cubic. + es = table(idx) * (1._rk-residual) + table(idx+1) * residual + +end function lookup_svp_in_table + +! Goff & Gratch (1946) + +pure function GoffGratch_svp_liquid(t) result(es) + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + ! Boiling point of water at 1 atm (K) + ! This is not really the most accurate value, but it is the one that the + ! Goff & Gratch scheme was designed to use, so we hard-code it. + real(rk), parameter :: tboil = 373.16_rk + + ! uncertain below -70 C + es = 10._rk**(-7.90298_rk*(tboil/t-1._rk)+ & + 5.02808_rk*log10(tboil/t)- & + 1.3816e-7_rk*(10._rk**(11.344_rk*(1._rk-t/tboil))-1._rk)+ & + 8.1328e-3_rk*(10._rk**(-3.49149_rk*(tboil/t-1._rk))-1._rk)+ & + log10(1013.246_rk))*100._rk + +end function GoffGratch_svp_liquid + +pure function GoffGratch_svp_ice(t) result(es) + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + ! good down to -100 C + es = 10._rk**(-9.09718_rk*(h2otrip/t-1._rk)-3.56654_rk* & + log10(h2otrip/t)+0.876793_rk*(1._rk-t/h2otrip)+ & + log10(6.1071_rk))*100._rk + +end function GoffGratch_svp_ice + +! Murphy & Koop (2005) + +pure function MurphyKoop_svp_liquid(t) result(es) + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + ! (good for 123 < T < 332 K) + es = exp(54.842763_rk - (6763.22_rk / t) - (4.210_rk * log(t)) + & + (0.000367_rk * t) + (tanh(0.0415_rk * (t - 218.8_rk)) * & + (53.878_rk - (1331.22_rk / t) - (9.44523_rk * log(t)) + & + 0.014025_rk * t))) + +end function MurphyKoop_svp_liquid + +pure function MurphyKoop_svp_ice(t) result(es) + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + ! (good down to 110 K) + es = exp(9.550426_rk - (5723.265_rk / t) + (3.53068_rk * log(t)) & + - (0.00728332_rk * t)) + +end function MurphyKoop_svp_ice + +! Taken from CLUBB, based on Bolton (1980). + +pure function Bolton_svp_liquid(t) result(es) + real(rk), parameter :: c1 = 611.2_rk + real(rk), parameter :: c2 = 17.67_rk + real(rk), parameter :: c3 = 29.65_rk + + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + es = c1*exp( (c2*(t - tmelt))/(t - c3) ) + +end function Bolton_svp_liquid + +pure function Bolton_svp_ice(t) result(es) + + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + es = exp( 27.93603_rk - (6111.72784_rk/t) + (0.15215_rk*log(t)) ) + +end function Bolton_svp_ice + +! "Flatau" scheme modified from CLUBB, based on: +! +! ``Polynomial Fits to Saturation Vapor Pressure'' Flatau, Walko, +! and Cotton. (1992) Journal of Applied Meteorology, Vol. 31, +! pp. 1507--1513 + +pure function Flatau_svp_liquid(t) result(es) + + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + real(rk), dimension(9), parameter :: coef = [ & + 6.11583699E+02_rk, 4.44606896E+01_rk, 1.43177157E+00_rk, & + 2.64224321E-02_rk, 2.99291081E-04_rk, 2.03154182E-06_rk, & + 7.02620698E-09_rk, 3.79534310E-12_rk,-3.21582393E-14_rk ] + + real(rk), parameter :: min_T_in_C = -85._rk + + real(rk) :: T_in_C + + T_in_C = max(t - tmelt, min_T_in_C) + + es = coef(1) + T_in_C * (coef(2) + T_in_C * (coef(3) + T_in_C * & + (coef(4) + T_in_C * (coef(5) + T_in_C * (coef(6) + T_in_C * & + (coef(7) + T_in_C * (coef(8) + T_in_C * coef(9)))))))) + +end function Flatau_svp_liquid + +pure function Flatau_svp_ice(t) result(es) + + real(rk), intent(in) :: t ! Temperature in Kelvin + real(rk) :: es ! SVP in Pa + + real(rk), dimension(9), parameter :: coef = [ & + 6.09868993E+02_rk, 4.99320233E+01_rk, 1.84672631E+00_rk, & + 4.02737184E-02_rk, 5.65392987E-04_rk, 5.21693933E-06_rk, & + 3.07839583E-08_rk, 1.05785160E-10_rk, 1.61444444E-13_rk ] + + real(rk), parameter :: min_T_in_C = -90._rk + + real(rk) :: T_in_C + + T_in_C = max(t - tmelt, min_T_in_C) + + es = coef(1) + T_in_C * (coef(2) + T_in_C * (coef(3) + T_in_C * & + (coef(4) + T_in_C * (coef(5) + T_in_C * (coef(6) + T_in_C * & + (coef(7) + T_in_C * (coef(8) + T_in_C * coef(9)))))))) + +end function Flatau_svp_ice + +end module shr_wv_sat_mod diff --git a/share/csm_share/test/old_unit_testers/Makefile b/share/csm_share/test/old_unit_testers/Makefile new file mode 100644 index 000000000000..7706964d413b --- /dev/null +++ b/share/csm_share/test/old_unit_testers/Makefile @@ -0,0 +1,163 @@ +#----------------------------------------------------------------------- +# This Makefile is for doing csm_share unit testing +#------------------------------------------------------------------------ +cpp_dirs := . ../shr ../../utils/mct/mct \ + ../../utils/mct/mpeu ../../utils/esmf_wrf_timemgr ../../utils/timing \ + ../../drv/shr +ifneq ($(SPMD),TRUE) +cpp_dirs += ../../utils/mct/mpi-serial +endif +cpp_dirs += ../../utils/pio +cpp_path := $(foreach dir,$(cpp_dirs),-I$(dir)) # format for command line + +# Platform specific macros +include make.Macros + +space := $(null) $(null) + +ifneq ($(ESMF_BLD),$(null)) +cpp_dirs += $(ESMF_LIB) +endif + +# Expand any tildes in directory names. +VPATH := $(foreach dir,$(cpp_dirs),$(wildcard $(dir))) +# Change spaces to colons. +VPATH := $(subst $(space),:,$(VPATH)) + +.PHONY: debug clean all + +all: test_shr_tInterp + + +ifneq ($(SPMD),TRUE) + OBJS_NOMPI := fort.o group.o collective.o comm.o list.o handles.o mpi.o recv.o req.o \ + send.o time.o +$(OBJS_NOMPI) shr_mpi_mod.o: mpif.h +mpif.h: + ln -s ../../utils/mct/mpi-serial/mpif.real4double8.h $@ +else + OBJS_NOMPI := $(null) +endif +OBJS_MCT := m_Accumulator.o m_AccumulatorComms.o m_AttrVect.o m_AttrVectComms.o \ + m_AttrVectReduce.o m_ConvertMaps.o m_ExchangeMaps.o m_GeneralGrid.o \ + m_GeneralGridComms.o m_GlobalMap.o m_GlobalSegMap.o \ + m_GlobalSegMapComms.o m_GlobalToLocal.o m_MCTWorld.o m_MatAttrVectMul.o \ + m_Merge.o m_Navigator.o m_Rearranger.o m_Router.o m_SparseMatrix.o \ + m_SparseMatrixComms.o m_SparseMatrixDecomp.o m_SparseMatrixPlus.o \ + m_SparseMatrixToMaps.o m_SpatialIntegral.o m_SpatialIntegralV.o \ + m_Transfer.o \ + m_FcComms.o m_FileResolv.o m_Filename.o m_IndexBin_char.o \ + m_IndexBin_integer.o m_IndexBin_logical.o m_List.o m_MergeSorts.o \ + m_Permuter.o m_SortingTools.o m_StrTemplate.o m_String.o m_TraceBack.o \ + m_chars.o m_die.o m_dropdead.o m_flow.o m_inpak90.o m_ioutil.o m_mall.o \ + m_mpif.o m_mpif90.o m_mpout.o m_rankMerge.o m_realkinds.o m_stdio.o \ + m_zeit.o get_zeits.o +OBJS_PIO := alloc_mod.o box_rearrange.o calcdisplace_mod.o iompi_mod.o \ + ionf_mod.o \ + nf_mod.o pio.o pio_kinds.o pio_mpi_utils.o pio_nf_utils.o \ + pio_msg_callbacks.o pio_msg_getput_callbacks.o pio_msg_mod.o \ + pio_nf_utils.o pio_quicksort.o pio_spmd_utils.o pio_support.o pio_types.o \ + pio_utils.o piodarray.o piolib_mod.o pionfatt_mod.o \ + pionfget_mod.o pionfput_mod.o pionfread_mod.o pionfwrite_mod.o \ + rearrange.o +OBJS_TIM := perf_mod.o perf_utils.o GPTLget_memusage.o GPTLprint_memusage.o \ + GPTLutil.o f_wrappers.o gptl.o gptl_papi.o threadutil.o + +OBJS := test_shr_sys.o shr_sys_mod.o shr_kind_mod.o shr_mpi_mod.o shr_const_mod.o shr_log_mod.o \ + $(OBJS_NOMPI) +OBJS_FILE := test_shr_file.o shr_sys_mod.o shr_kind_mod.o shr_file_mod.o shr_mpi_mod.o shr_log_mod.o \ + $(OBJS_NOMPI) +OBJS_ORB := test_shr_orb.o shr_sys_mod.o shr_kind_mod.o shr_orb_mod.o shr_mpi_mod.o shr_log_mod.o \ + shr_const_mod.o $(OBJS_NOMPI) +OBJS_STRMS := test_shr_streams.o shr_kind_mod.o shr_stream_mod.o shr_sys_mod.o \ + shr_file_mod.o shr_string_mod.o shr_timer_mod.o shr_mpi_mod.o \ + shr_cal_mod.o shr_ncread_mod.o shr_const_mod.o \ + shr_log_mod.o test_mod.o $(OBJS_NOMPI) +OBJS_SCAM := test_shr_scam.o shr_strdata_mod.o shr_const_mod.o shr_kind_mod.o \ + shr_log_mod.o shr_sys_mod.o shr_file_mod.o shr_stream_mod.o \ + shr_map_mod.o shr_string_mod.o shr_cal_mod.o shr_orb_mod.o \ + shr_tinterp_mod.o shr_dmodel_mod.o shr_mct_mod.o mct_mod.o \ + perf_mod.o pio.o shr_mpi_mod.o seq_flds_mod.o shr_ncread_mod.o \ + shr_scam_mod.o shr_pcdf_mod.o shr_mct_mod.o mct_mod.o shr_timer_mod.o \ + seq_drydep_mod.o test_mod.o \ + $(OBJS_NOMPI) $(OBJS_MCT) $(OBJS_PIO) $(OBJS_TIM) +OBJS_STIN := test_shr_tInterp.o shr_kind_mod.o shr_const_mod.o shr_sys_mod.o \ + shr_string_mod.o shr_cal_mod.o shr_log_mod.o shr_orb_mod.o test_mod.o \ + shr_tInterp_mod.o shr_timer_mod.o shr_mpi_mod.o $(OBJS_NOMPI) +OBJS_MPI := test_shr_mpi.o shr_mpi_mod.o shr_kind_mod.o shr_sys_mod.o shr_const_mod.o shr_log_mod.o $(OBJS_NOMPI) + +OBJS_LOG := test_shr_log.o shr_log_mod.o shr_kind_mod.o \ + test_mod.o shr_sys_mod.o shr_mpi_mod.o $(OBJS_NOMPI) + +WRFESMF_OBJS := ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ + Meat.o ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o \ + ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF_Mod.o \ + ESMF_AlarmClockMod.o wrf_error_fatal.o wrf_message.o + +ifeq ($(ESMF_BLD),$(null)) + OBJS_STIN += $(WRFESMF_OBJS) + OBJS_STRMS += $(WRFESMF_OBJS) + OBJS_SCAM += $(WRFESMF_OBJS) +endif + +# +# Executables: +# + +debug: + @echo "VPATH: " $(VPATH) + @echo "ESMF_MOD: " $(ESMF_MOD) + @echo "ESMF_ARCH: " $(ESMF_ARCH) + @echo "FC: " $(FC) + @echo "INC_NETCDF: " $(INC_NETCDF) + @echo "LIB_MPI: " $(LIB_MPI) +test_shr_sys: $(OBJS) + $(LD) -o test_shr_sys $(OBJS) $(LDFLAGS) +test_shr_file: $(OBJS_FILE) + $(LD) -o test_shr_file $(OBJS_FILE) $(LDFLAGS) +test_shr_orb: $(OBJS_ORB) + $(LD) -o test_shr_orb $(OBJS_ORB) $(LDFLAGS) +test_shr_streams: $(OBJS_STRMS) + $(LD) -o test_shr_streams $(OBJS_STRMS) $(LDFLAGS) +test_shr_tInterp: $(OBJS_STIN) + $(LD) -o test_shr_tInterp $(OBJS_STIN) $(LDFLAGS) +test_shr_mpi: $(OBJS_MPI) + $(LD) -o test_shr_mpi $(OBJS_MPI) $(LDFLAGS) +test_shr_scam: $(OBJS_SCAM) + $(LD) -o test_shr_scam $(OBJS_SCAM) $(LDFLAGS) +test_shr_log: $(OBJS_LOG) + $(LD) -o test_shr_log $(OBJS_LOG) $(LDFLAGS) + +clean: + $(RM) -f *.mod *.o *.f *.f90 F mpif.h test_shr_sys test_shr_orb \ + test_shr_file tests_shr_streams tests_shr_tInterp \ + test_shr_mpi libesmf.a test_shr_scam test_shr_log Depends Srcfiles Filepath + +# +# Dependencies +# +Depends: Srcfiles Filepath + ./Mkdepends Filepath Srcfiles > $@ + +paths := $(subst $(space),"\n",$(cpp_dirs)) + +Srcfiles: Filepath + ./Mksrcfiles > $@ + +Filepath: + @echo -e $(paths) > $@ + +-include Depends + +# ESMF code... +ifeq ($(ESMF_BLD),$(null)) + +AR := ar +CPP := cpp + +libesmf.a : $(WRFESMF_OBJS) + $(RM) -f libesmf.a + $(AR) $(ARFLAGS) libesmf.a $(WRFESMF_OBJS) + $(RANLIB) libesmf.a + +endif diff --git a/share/csm_share/test/old_unit_testers/Mkdepends b/share/csm_share/test/old_unit_testers/Mkdepends new file mode 100755 index 000000000000..a75e8fdde0ad --- /dev/null +++ b/share/csm_share/test/old_unit_testers/Mkdepends @@ -0,0 +1,327 @@ +#!/usr/bin/env perl + +# Generate dependencies in a form suitable for inclusion into a Makefile. +# The source filenames are provided in a file, one per line. Directories +# to be searched for the source files and for their dependencies are provided +# in another file, one per line. Output is written to STDOUT. +# +# For CPP type dependencies (lines beginning with #include) the dependency +# search is recursive. Only dependencies that are found in the specified +# directories are included. So, for example, the standard include file +# stdio.h would not be included as a dependency unless /usr/include were +# one of the specified directories to be searched. +# +# For Fortran module USE dependencies (lines beginning with a case +# insensitive "USE", possibly preceded by whitespace) the Fortran compiler +# must be able to access the .mod file associated with the .o file that +# contains the module. In order to correctly generate these dependencies +# two restrictions must be observed. +# 1) All modules must be contained in files that have the same base name as +# the module, in a case insensitive sense. This restriction implies that +# there can only be one module per file. +# 2) All modules that are to be contained in the dependency list must be +# contained in one of the source files in the list provided on the command +# line. +# The reason for the second restriction is that since the makefile doesn't +# contain rules to build .mod files the dependency takes the form of the .o +# file that contains the module. If a module is being used for which the +# source code is not available (e.g., a module from a library), then adding +# a .o dependency for that module is a mistake because make will attempt to +# build that .o file, and will fail if the source code is not available. +# +# Author: B. Eaton +# Climate Modelling Section, NCAR +# Feb 2001 + +use Getopt::Std; +use File::Basename; + +# Check for usage request. +@ARGV >= 2 or usage(); + +# Process command line. +my %opt = (); +getopts( "t:w", \%opt ) or usage(); +my $filepath_arg = shift() or usage(); +my $srcfile_arg = shift() or usage(); +@ARGV == 0 or usage(); # Check that all args were processed. + +my $obj_dir; +if ( defined $opt{'t'} ) { $obj_dir = $opt{'t'}; } + +open(FILEPATH, $filepath_arg) or die "Can't open $filepath_arg: $!\n"; +open(SRCFILES, $srcfile_arg) or die "Can't open $srcfile_arg: $!\n"; + +# Make list of paths to use when looking for files. +# Prepend "." so search starts in current directory. This default is for +# consistency with the way GNU Make searches for dependencies. +my @file_paths = ; +close(FILEPATH); +chomp @file_paths; +unshift(@file_paths,'.'); +foreach $dir (@file_paths) { # (could check that directories exist here) + $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name + ($dir) = glob $dir; # Expand tildes in path names. +} + +# Make list of files containing source code. +my @src = ; +close(SRCFILES); +chomp @src; + +# For each file that may contain a Fortran module (*.[fF]90 *.[fF]) convert the +# file's basename to uppercase and use it as a hash key whose value is the file's +# basename. This allows fast identification of the files that contain modules. +# The only restriction is that the file's basename and the module name must match +# in a case insensitive way. +my %module_files = (); +my ($f, $name, $path, $suffix, $mod); +my @suffixes = ('\.[fF]90', '\.[fF]' ); +foreach $f (@src) { + ($name, $path, $suffix) = fileparse($f, @suffixes); + ($mod = $name) =~ tr/a-z/A-Z/; + $module_files{$mod} = $name; +} + +# Now make a list of .mod files in the file_paths. If a .o source dependency +# can't be found based on the module_files list above, then maybe a .mod +# module dependency can if the mod file is visible. +my %trumod_files = (); +my ($dir); +my ($f, $name, $path, $suffix, $mod); +my @suffixes = ('\.mod' ); +foreach $dir (@file_paths) { + @filenames = (glob("$dir/*.mod")); + foreach $f (@filenames) { + ($name, $path, $suffix) = fileparse($f, @suffixes); + ($mod = $name) =~ tr/a-z/A-Z/; + $trumod_files{$mod} = $name; + } +} + +#print STDERR "\%module_files\n"; +#while ( ($k,$v) = each %module_files ) { +# print STDERR "$k => $v\n"; +#} + +# Find module and include dependencies of the source files. +my ($file_path, $rmods, $rincs); +my %file_modules = (); +my %file_includes = (); +my @check_includes = (); +foreach $f ( @src ) { + + # Find the file in the seach path (@file_paths). + unless ($file_path = find_file($f)) { + if (defined $opt{'w'}) {print STDERR "$f not found\n";} + next; + } + + # Find the module and include dependencies. + ($rmods, $rincs) = find_dependencies( $file_path ); + + # Remove redundancies (a file can contain multiple procedures that have + # the same dependencies). + $file_modules{$f} = rm_duplicates($rmods); + $file_includes{$f} = rm_duplicates($rincs); + + # Make a list of all include files. + push @check_includes, @{$file_includes{$f}}; +} + +#print STDERR "\%file_modules\n"; +#while ( ($k,$v) = each %file_modules ) { +# print STDERR "$k => @$v\n"; +#} +#print STDERR "\%file_includes\n"; +#while ( ($k,$v) = each %file_includes ) { +# print STDERR "$k => @$v\n"; +#} +#print STDERR "\@check_includes\n"; +#print STDERR "@check_includes\n"; + +# Find include file dependencies. +my %include_depends = (); +while (@check_includes) { + $f = shift @check_includes; + if (defined($include_depends{$f})) { next; } + + # Mark files not in path so they can be removed from the dependency list. + unless ($file_path = find_file($f)) { + $include_depends{$f} = -1; + next; + } + + # Find include file dependencies. + ($rmods, $include_depends{$f}) = find_dependencies($file_path); + + # Add included include files to the back of the check_includes list so + # that their dependencies can be found. + push @check_includes, @{$include_depends{$f}}; + + # Add included modules to the include_depends list. + if ( @$rmods ) { push @{$include_depends{$f}}, @$rmods; } +} + +#print STDERR "\%include_depends\n"; +#while ( ($k,$v) = each %include_depends ) { +# print STDERR (ref $v ? "$k => @$v\n" : "$k => $v\n"); +#} + +# Remove include file dependencies that are not in the Filepath. +my $i, $ii; +foreach $f (keys %include_depends) { + + unless (ref $include_depends{$f}) { next; } + $rincs = $include_depends{$f}; + unless (@$rincs) { next; } + $ii = 0; + $num_incs = @$rincs; + for ($i = 0; $i < $num_incs; ++$i) { + if ($include_depends{$$rincs[$ii]} == -1) { + splice @$rincs, $ii, 1; + next; + } + ++$ii; + } +} + +# Substitute the include file dependencies into the %file_includes lists. +foreach $f (keys %file_includes) { + my @expand_incs = (); + + # Initialize the expanded %file_includes list. + my $i; + unless (@{$file_includes{$f}}) { next; } + foreach $i (@{$file_includes{$f}}) { + push @expand_incs, $i unless ($include_depends{$i} == -1); + } + unless (@expand_incs) { + $file_includes{$f} = []; + next; + } + + # Expand + for ($i = 0; $i <= $#expand_incs; ++$i) { + push @expand_incs, @{ $include_depends{$expand_incs[$i]} }; + } + + $file_includes{$f} = rm_duplicates(\@expand_incs); +} + +#print STDERR "expanded \%file_includes\n"; +#while ( ($k,$v) = each %file_includes ) { +# print STDERR "$k => @$v\n"; +#} + +# Print dependencies to STDOUT. +foreach $f (sort keys %file_modules) { + $f =~ /(.+)\./; + $target = "$1.o"; + if ( defined $opt{'t'} ) { $target = "$opt{'t'}/$1.o"; } + print "$target : $f @{$file_modules{$f}} @{$file_includes{$f}}\n"; +} + +#-------------------------------------------------------------------------------------- + +sub find_dependencies { + + # Find dependencies of input file. + # Use'd Fortran 90 modules are returned in \@mods. + # Files that are "#include"d by the cpp preprocessor are returned in \@incs. + + my( $file ) = @_; + my( @mods, @incs ); + + open(FH, $file) or die "Can't open $file: $!\n"; + + while ( ) { + # Search for "#include" and strip filename when found. + if ( /^#include\s+[<"](.*)[>"]/ ) { + push @incs, $1; + } + # Search for Fortran include dependencies. + elsif ( /^\s*include\s+['"](.*)['"]/ ) { #" for emacs fontlock + push @incs, $1; + } + # Search for module dependencies. + elsif ( /^\s*USE\s+(\w+)/i ) { + ($module = $1) =~ tr/a-z/A-Z/; + # Return dependency in the form of a .o version of the file that contains + # the module. this is from the source list. + if ( defined $module_files{$module} ) { + if ( defined $obj_dir ) { + push @mods, "$obj_dir/$module_files{$module}.o"; + } else { + push @mods, "$module_files{$module}.o"; + } + } + # Return dependency in the form of a .mod version of the file that contains + # the module. this is from the .mod list. only if .o version not found + elsif ( defined $trumod_files{$module} ) { + if ( defined $obj_dir ) { + push @mods, "$obj_dir/$trumod_files{$module}.mod"; + } else { + push @mods, "$trumod_files{$module}.mod"; + } + } + } + } + close( FH ); + return (\@mods, \@incs); +} + +#-------------------------------------------------------------------------------------- + +sub find_file { + +# Search for the specified file in the list of directories in the global +# array @file_paths. Return the first occurance found, or the null string if +# the file is not found. + + my($file) = @_; + my($dir, $fname); + + foreach $dir (@file_paths) { + $fname = "$dir/$file"; + if ( -f $fname ) { return $fname; } + } + return ''; # file not found +} + +#-------------------------------------------------------------------------------------- + +sub rm_duplicates { + +# Return a list with duplicates removed. + + my ($in) = @_; # input arrary reference + my @out = (); + my $i; + my %h = (); + foreach $i (@$in) { + $h{$i} = ''; + } + @out = keys %h; + return \@out; +} + +#-------------------------------------------------------------------------------------- + +sub usage { + ($ProgName = $0) =~ s!.*/!!; # name of program + die < Srcfiles") or die "Can't open Srcfiles\n"; + +if ( open(FILEPATH,"< Filepath") ) { + @paths = ; + close( FILEPATH ); +} else { + @paths = (); +} +chomp @paths; +unshift(@paths, '.'); +foreach $dir (@paths) { # (could check that directories exist here) + $dir =~ s!/?\s*$!!; # remove / and any whitespace at end of directory name + ($dir) = glob $dir; # Expand tildes in path names. +} + +# Loop through the directories and add each filename as a hash key. This +# automatically eliminates redunancies. +%src = (); +foreach $dir (@paths) { + @filenames = (glob("$dir/*.[Fc]"), glob("$dir/*.[Ff]90")); + foreach $filename (@filenames) { + $filename =~ s!.*/!!; # remove part before last slash + $src{$filename} = ""; + } +} + +foreach $file ( sort keys %src ) { + print SRC "$file\n"; +} +close( SRC ); + +#-------------------------------------------------------------------------------------- + +sub usage { + ($ProgName = $0) =~ s!.*/!!; # name of program + die < 0.0_r8 )then + diff = abs(data(i,j,f) - exp_data(i,j,f)) + ndata = ndata + 1 + meansq = meansq + diff**2 + if ( trim(lcrittype) == "rel_diff" .and. diff > 0.0_r8 ) diff = diff / max( abs(data(i,j,f)), abs(exp_data(i,j,f)) ) + if ( diff > max_diff ) max_diff = diff + if ( diff > eps .and. .not. trim(lcrittype) == "rms_diff" )then + bundle_closeto_expected = .false. + end if + end if + end do + end do + end do outloop + deallocate( mask ) + rms_diff = sqrt(meansq/ndata) + if ( rms_diff > eps .and. trim(lcrittype) == "rms_diff" ) bundle_closeto_expected = .false. + write(*,*) "bundle_closeto_expected: max_diff = ", max_diff, " RMS diff = ", rms_diff + end if + +end function bundle_closeto_expected + +logical function bundle_metadata_is_expected( bun, expected_bun ) + use dshr_bundle, only : dshr_bundle_domainPtr, dshr_bundle_getDims, dshr_bundle_getFieldList, & + dshr_bundle_getDate + use dshr_domain, only : dshr_domain_compare + implicit none + + type(dshr_bundle_bundleType), intent(IN) :: bun ! bundle to test + type(dshr_bundle_bundleType), intent(IN) :: expected_bun ! expected bundle + + type(dshr_domain_domainType),pointer :: domain + type(dshr_domain_domainType),pointer :: exp_domain + logical :: status + integer :: ni, nj, nf, exp_ni, exp_nj, exp_nf + integer :: date, sec, exp_date, exp_sec + character(SHR_KIND_CX) :: fldlist, exp_fldlist + + + call dshr_bundle_domainPtr( bun, domain ) + call dshr_bundle_domainPtr( expected_bun, exp_domain ) + + status = dshr_domain_compare( domain, exp_domain, method=dshr_domain_compareMaskIdent, eps=0.0_r8 ) + if ( status )then + status = dshr_domain_compare( domain, exp_domain, method=dshr_domain_compareXYabs, eps=0.0_r8 ) + end if + if ( status )then + call dshr_bundle_getDims( bun, ni, nj, nf ) + call dshr_bundle_getDims( bun, exp_ni, exp_nj, exp_nf ) + if ( ni /= exp_ni .or. nj /= exp_nj .or. nf /= exp_nf ) status = .false. + end if + if ( status )then + call dshr_bundle_getFieldList( bun, fldlist ) + call dshr_bundle_getFieldList( expected_bun, exp_fldlist ) + if ( trim(fldlist) /= trim(exp_fldlist) ) status = .false. + end if + if ( status )then + call dshr_bundle_getDate (bun,date,sec) + call dshr_bundle_getDate (expected_bun,exp_date,exp_sec) + if ( date /= exp_date .or. sec /= exp_sec ) status = .false. + end if + + bundle_metadata_is_expected = status + +end function bundle_metadata_is_expected + +subroutine bundle_fill_cosz( scale, orb_eccen, orb_mvelpp, orb_lambm0, orb_obliqr, sdate_ub, domain, bun, kfld ) +! Fill a bundle with data scaled by the average cosine of the solar zenith angle + use shr_string_mod + use shr_const_mod + use shr_orb_mod + use dshr_domain + use shr_sys_mod + implicit none + real(r8), intent(IN) :: scale + real(r8), intent(IN) :: orb_eccen, orb_mvelpp, orb_lambm0, orb_obliqr + type(shr_date), intent(IN) :: sdate_ub ! Upper bound of date for + type(dshr_domain_domainType), pointer :: domain + type(dshr_bundle_bundleType), intent(INOUT) :: bun ! bundle to fill + integer, intent(in) :: kfld ! Which field number to fill + + character(len=*), parameter :: subname = "bundle_fill_cosz" + real(r8), pointer :: data(:,:,:), lat(:,:), lon(:,:), sumcosz(:,:) + real(r8) :: cosz, calday, declin, eccf, calday_end + integer :: i, j, f, ni, nj, nf, rc, t, ntimes, date_lb, sec_lb + integer, parameter :: dtime = 18 + type(shr_date) :: sdate + + call dshr_domain_getDims(domain,ni,nj) + allocate( lat(ni,nj) ) + allocate( lon(ni,nj) ) + allocate( sumcosz(ni,nj) ) + call dshr_domain_getData( domain, lat, "lat" ) + call dshr_domain_getData( domain, lon, "lon" ) + lat = lat * SHR_CONST_PI / 180._r8 + lon = lon * SHR_CONST_PI / 180._r8 + + call dshr_bundle_assignPtr( bun, data ) + call dshr_bundle_getDate( bun, cdate=date_lb, sec=sec_lb ) + sdate = shr_date_initCDate( date_lb, 3600*24/dtime, sec_lb ) + calday_end = shr_date_getJulian( sdate_ub ) + sumcosz(:,:) = 0.0_r8 + calday = 0.0_r8 + ntimes = 0 + calday = shr_date_getJulian( sdate ) + nf = size( data, 3 ) + if ( kfld <= 0 .or. kfld > nf ) call shr_sys_abort( 'input kfld is out of bounds' ) + do while( sdate < sdate_ub .or. sdate == sdate_ub ) + ntimes = ntimes + 1 + call shr_orb_decl(calday ,orb_eccen ,orb_mvelpp ,orb_lambm0 ,orb_obliqr ,declin,eccf) + do j = 1, nj + do i = 1, ni + cosz = shr_orb_cosz(calday,lat(i,j),lon(i,j),declin) + if ( cosz < 0.01_r8 ) cosz = 0.01_r8 + if ( cosz < 0.001_r8 ) cosz = 0.001_r8 + sumcosz(i,j) = cosz + sumcosz(i,j) + end do + end do + call shr_date_adv1step( sdate ) + calday = shr_date_getJulian( sdate ) + end do + data(:,:,kfld) = sumcosz(:,:)*scale/real(ntimes,r8) + + nullify( data ) + nullify( domain ) + deallocate( lat ) + deallocate( lon ) + deallocate( sumcosz ) + +end subroutine bundle_fill_cosz + +end module bundle_expected diff --git a/share/csm_share/test/old_unit_testers/config.h b/share/csm_share/test/old_unit_testers/config.h new file mode 100644 index 000000000000..03f5a6a23ab0 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/config.h @@ -0,0 +1,7 @@ +#ifdef FORTRAN_SAME +#define FC_FUNC(name,NAME) name +#elif FORTRAN_UNDERSCORE_ +#define FC_FUNC(name,NAME) name ##_ +#elif FORTRAN_DOUBLE_UNDERSCORE_ +#define FC_FUNC(name,NAME) name ##__ +#endif diff --git a/share/csm_share/test/old_unit_testers/make.Macros b/share/csm_share/test/old_unit_testers/make.Macros new file mode 100644 index 000000000000..b72f4d842faf --- /dev/null +++ b/share/csm_share/test/old_unit_testers/make.Macros @@ -0,0 +1,369 @@ +#--------------------------------------------------------------------- +# Platform specific macros for csm_share unit tests +#------------------------------------------------------------------------ +# Set up special characters +null := + +.SUFFIXES: .F90 .c .o + +# Cancel rule to make *.o from *.mod +%.o : %.mod + +# Defines to use everywhere + +cpre = $(null)-WF,-D$(null) +CPPDEF := -DESMF_3 -D_NETCDF + +ifeq ($(ESMF_3),TRUE) + CPPDEF += -DESMF_3 +endif + +ifneq ($(SPMD),TRUE) + CPPDEF += -D_MPISERIAL +endif + +LD := $(FC) + + +CPPDEF += -DSEQ_ESMF -DNOPERF +# For linking with external ESMF +# If ESMF_BLD is defined then set ESMF_MOD and ESMF_LIB based on it +ifneq ($(ESMF_BLD),$(null)) + ESMF_BOPT := g + ESMF_MOD = $(ESMF_BLD)/mod/mod$(ESMF_BOPT)/$(ESMF_ARCH) + ESMF_LIB = $(ESMF_BLD)/lib/lib$(ESMF_BOPT)/$(ESMF_ARCH) +else + ESMF_MOD := . + ESMF_LIB := . +endif + +# Determine platform +UNAMES := $(shell uname -s) + +.F90.o: + $(FC) -c $(FFLAGS) $< +.c.o: + $(CC) -c $(CFLAGS) $< + +#------------------------------------------------------------------------ +# Linux +#------------------------------------------------------------------------ + +ifeq ($(UNAMES),Linux) + +ifeq ($(FC),f77) + FC := pgfortran +endif + +CFLAGS := +LDFLAGS := +ifeq ($(FC),pgfortran) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRPGI + ifeq ($(INC_MPI),$(null)) + INC_MPI := /usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/include + endif + ifeq ($(LIB_MPI),$(null)) + LIB_MPI := /usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/lib + endif + ifeq ($(INC_NETCDF),$(null)) + INC_NETCDF := /usr/local/netcdf-3.6.1-pgi-hpf-cc-6.1-6/include + endif + ifeq ($(LIB_NETCDF),$(null)) + LIB_NETCDF := /usr/local/netcdf-3.6.1-pgi-hpf-cc-6.1-6/lib + endif + CC := pgcc + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux.pgi.32.mpich.default + else + ESMF_ARCH := Linux.pgi.32.mpiuni.default + endif + F90FLAGS := -Mfree + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) -Mrecursive -Mdalign \ + -Mextend $(cpp_path) -I$(INC_NETCDF) \ + -g -Mbounds -I$(INC_MPI) + ifneq ($(FLTTRAP),FALSE) + FFLAGS += -Ktrap=fp + endif + LDFLAGS += -Bstatic +endif +ifeq ($(FC),nagfor) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRNAG + ifeq ($(INC_MPI),$(null)) + INC_MPI := /home/santos/mpich-gcc-nag/include + endif + ifeq ($(LIB_MPI),$(null)) + LIB_MPI := /home/santos/mpich-gcc-nag/lib + endif + ifeq ($(INC_NETCDF),$(null)) + INC_NETCDF := /usr/local/netcdf-gcc-nag/include + endif + ifeq ($(LIB_NETCDF),$(null)) + LIB_NETCDF := /usr/local/netcdf-gcc-nag/lib + endif + CC := gcc + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux.pgi.32.mpich.default + else + ESMF_ARCH := Linux.pgi.32.mpiuni.default + endif + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ + $(cpp_path) -I$(INC_NETCDF) \ + -g -I$(INC_MPI) + FFLAGS += -wmismatch=mpi_send,mpi_recv,mpi_bcast,mpi_reduce,mpi_allreduce + ifeq ($(FLTTRAP),FALSE) + FFLAGS += -ieee=full + endif +endif +ifeq ($(FC),pathf90) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ + CC := pathcc + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux..pathscale.32.mpich.default + else + ESMF_ARCH := Linux.pathscale.32.mpiuni.default + endif + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ + $(cpp_path) -I$(INC_NETCDF) \ + -g -extend_source -ftpp -fno-second-underscore +endif +ifeq ($(FC),ftn) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ + CC := pathcc + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux..pathscale.32.mpich.default + else + ESMF_ARCH := Linux.pathscale.32.mpiuni.default + endif + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ + $(cpp_path) -I$(INC_NETCDF) \ + -g -extend_source -ftpp -fno-second-underscore +endif +ifeq ($(FC),ifort) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ -DCPRINTEL + CC := icc + ifeq ($(INC_MPI),$(null)) + INC_MPI := /usr/local/mpich-intel/include + endif + ifeq ($(LIB_MPI),$(null)) + LIB_MPI := /usr/local/mpich-intel/lib + endif + ifeq ($(INC_NETCDF),$(null)) + INC_NETCDF := /usr/local/netcdf-intel/include + endif + ifeq ($(LIB_NETCDF),$(null)) + LIB_NETCDF := /usr/local/netcdf-intel/lib + endif + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux.ifort.32.mpich.default + else + ESMF_ARCH := Linux.ifort.32.mpiuni.default + endif + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ + $(cpp_path) -I$(INC_NETCDF) \ + -m64 -ftz -g -fp-model precise -convert big_endian -assume byterecl -traceback -CB + CFLAGS += -m64 -ftz -v + LDFLAGS += -m64 +endif +ifeq ($(FC),gfortran) + CPPDEF += -DLINUX -DFORTRAN_SAME -DCPRGNU + CC := cc + FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ + $(FPPFLAGS) -g -fbounds-check -fno-range-check -m64 + CFLAGS += -m64 + LDFLAGS += -static -m64 -ffpe-trap=invalid,zero,overflow -fno-range-check + ifneq ($(FLTTRAP),FALSE) + LDFLAGS += -ffpe-trap=invalid,zero,overflow + FFLAGS += -ffpe-trap=invalid,zero,overflow + endif +endif +ifeq ($(FC),g95) + CPPDEF += -DFORTRAN_SAME + CC := gcc + FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ + $(FPPFLAGS) -g -fbounds-check -m64 -ffree-line-length-huge + CFLAGS += -m64 + LDFLAGS += -fstatic -m64 + ifneq ($(FLTTRAP),FALSE) + LDFLAGS += -ffpe-trap=invalid,zero,overflow + FFLAGS += -ffpe-trap=invalid,zero,overflow + endif +endif +ifeq ($(FC),xlf2003_r) + CPPDEF += -DLINUX -DFORTRAN_SAME -DCPRIBM + AIX_CPPDEF := $(patsubst -D%,$(cpre)%,$(CPPDEF)) + FPPFLAGS := -WF,-P,$(AIX_CPPDEF) + ESMF_ARCH := AIX.default.64.mpiuni.default + ifeq ($(INC_NETCDF),$(null)) + INC_NETCDF := /soft/libraries/netcdf/4.2.1.1/cnk-xl/V1R2M0-20130417/include + endif + ifeq ($(LIB_NETCDF),$(null)) + LIB_NETCDF := /soft/libraries/netcdf/4.2.1.1/cnk-xl/V1R2M0-20130417/lib + endif + FREEFLAGS := -qsuffix=f=f90:cpp=F90 + FFLAGS := $(FREEFLAGS) $(cpp_path) -I$(INC_NETCDF) -I$(LIB_NETCDF) $(FPPFLAGS) \ + -qarch=auto -qspillsize=2500 \ + -g -qfullpath -q64 -C -d + CC := cc_r + CFLAGS += -O2 -q64 + LDFLAGS += -q64 -L/bgsys/drivers/ppcfloor/comm/lib -Wl,--relax -Wl,--allow-multiple-definition -qfullpath + ifneq ($(FLTTRAP),FALSE) + FFLAGS += -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qhalt=w + endif + ifeq ($(SPMD),TRUE) + LDFLAGS += -lmpi_r + endif + ifeq ($(SMP),TRUE) + FFLAGS += -qsmp=omp:noopt + LDFLAGS += -qsmp=omp:noopt + endif + +endif +LDFLAGS += -L$(LIB_NETCDF) -lnetcdf +ifeq ($(SPMD),TRUE) + LDFLAGS += -L$(LIB_MPI) -lmpich +endif +CFLAGS += $(cpp_path) $(CPPDEF) +LD := $(FC) +ARFLAGS := ru +RANLIB := echo + +# For linking with external ESMF +ifneq ($(ESMF_BLD),$(null)) + FFLAGS += -M$(ESMF_BLD)/mod/mod$(ESMF_BOPT)/$(ESMF_ARCH) -M. +endif + +#.F90.o: +# $(FC) $(CPPFLAGS) $< +# $(FC) $(F90FLAGS) $*.f + +endif +#------------------------------------------------------------------------ +# AIX +#------------------------------------------------------------------------ +ifeq ($(UNAMES),AIX) + +ifeq ($(SPMD),TRUE) + FC := mpxlf90_r + ESMF_ARCH := AIX.default.64.mpi.default +else + FC := xlf90_r + ESMF_ARCH := AIX.default.64.mpiuni.default +endif +CPPDEF += -DFORTRAN_SAME -DCPRIBM +AIX_CPPDEF := $(patsubst -D%,$(cpre)%,$(CPPDEF)) +FPPFLAGS := -WF,-P,-DAIX $(AIX_CPPDEF) +FREEFLAGS := -qsuffix=f=f90:cpp=F90 +FFLAGS := $(FREEFLAGS) $(cpp_path) -I$(INC_NETCDF) -I$(LIB_NETCDF) $(FPPFLAGS) \ + -qarch=auto -qspillsize=2500 \ + -g -qfullpath -q64 -C -d +CC := mpcc_r +CFLAGS := $(cpp_path) -O2 $(CPPDEF) -q64 +LDFLAGS := -L$(LIB_NETCDF) -lnetcdf -q64 -lmassv +LD := $(FC) +ifneq ($(FLTTRAP),FALSE) + FFLAGS += -qinitauto=FF911299 -qflttrap=ov:zero:inv:en -qhalt=w +endif +ifeq ($(FC),mpxlf90_r) + LDFLAGS += -lmpi_r +endif +ifeq ($(SMP),TRUE) + FFLAGS += -qsmp=omp:noopt + LDFLAGS += -qsmp=omp:noopt +endif +ARFLAGS := -X 64 ru +RANLIB := ranlib + +endif + +#------------------------------------------------------------------------ +# Darwin +#------------------------------------------------------------------------ +ifeq ($(UNAMES),Darwin) + +CC := gcc +LDFLAGS := -g -L$(LIB_NETCDF) -lnetcdf -lSystemStubs + +ifeq ($(FC),ifort) + CPPDEF += -DLINUX -DFORTRAN_UNDERSCORE_ + CC := icc + ifeq ($(INC_MPI),$(null)) + INC_MPI := /usr/local/mpich-intel/include + endif + ifeq ($(LIB_MPI),$(null)) + LIB_MPI := /usr/local/mpich-intel/lib + endif + ifeq ($(INC_NETCDF),$(null)) + INC_NETCDF := /usr/local/netcdf-intel/include + endif + ifeq ($(LIB_NETCDF),$(null)) + LIB_NETCDF := /usr/local/netcdf-intel/lib + endif + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Linux.ifort.32.mpich.default + else + ESMF_ARCH := Linux.ifort.32.mpiuni.default + endif + FFLAGS := $(CPPFLAGS) $(CPPDEF) $(F90FLAGS) \ + $(cpp_path) -I$(INC_NETCDF) \ + -m64 -ftz -g -fp-model precise -convert big_endian -assume byterecl -traceback -CB + CFLAGS += -m64 -ftz -v + LDFLAGS += -m64 + gptl.o: gptl.c + $(CC) -c -I/usr/include/machine $(CFLAGS) $< +endif +ifeq ($(FC),g95) + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Darwin.g95.32.mpich.default + else + ESMF_ARCH := Darwin.g95.32.mpiuni.default + endif + FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ + $(FPPFLAGS) -g -fbounds-check -fstatic -ffree-line-length-huge -ffree-form \ + -ftrace=full +endif +ifeq ($(FC),gfortran) + ifeq ($(SPMD),TRUE) + ESMF_ARCH := Darwin.gfortran.32.mpich.default + else + ESMF_ARCH := Darwin.gfortran.32.mpiuni.default + endif + FFLAGS := -fno-underscoring $(CPPDEF) $(cpp_path) -I$(INC_NETCDF) \ + $(FPPFLAGS) -g -fbounds-check -fno-range-check + ifneq ($(FLTTRAP),FALSE) + LDFLAGS += -ffpe-trap=invalid,zero,overflow + FFLAGS += -ffpe-trap=invalid,zero,overflow + endif + LDFLAGS += -static +endif +CFLAGS := $(cpp_path) -O2 $(CPPDEF) \ + -I/Developer/SDKs/MacOSX10.4.0.sdk/usr/include/malloc -I/usr/include -I/usr/include/malloc +ARFLAGS := ru +RANLIB := ranlib +LD := $(FC) + +# For linking with MPICH +ifeq ($(SPMD),TRUE) + LDFLAGS += -lmpich + LD := mpif90 +endif +LDFLAGS += -lSystemStubs_profile + +# For linking with external ESMF +ifneq ($(ESMF_BLD),$(null)) + LDFLAGS += -lgcc_s.1.0 -lSystemStubs_debug +endif + +endif + +#------------------------------------------------------------------------ +# End of platform specific +#------------------------------------------------------------------------ +# For linking with external ESMF +ifneq ($(ESMF_BLD),$(null)) + include $(ESMF_BLD)/lib/esmf.mk + LDFLAGS += $(ESMF_F90LINKRPATHS) $(ESMF_F90LINKPATHS) $(ESMF_F90ESMFLINKLIBS) $(ESMF_CXXLINKLIBS) + FFLAGS += $(ESMF_F90COMPILEPATHS) + LD := $(ESMF_F90LINKER) +endif + +RM := rm diff --git a/share/csm_share/test/old_unit_testers/namelist b/share/csm_share/test/old_unit_testers/namelist new file mode 100644 index 000000000000..a09965011af2 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/namelist @@ -0,0 +1,10 @@ +# No stop date +&ccsm_inparm + case_desc = 'Erik' +/ +&timemgr_inparm + restart_monthly = .true. + atm_cpl_dt = 1200 + orb_iyear_AD = 1950 + start_ymd = 1231 +/ diff --git a/share/csm_share/test/old_unit_testers/nl/atm.stdin b/share/csm_share/test/old_unit_testers/nl/atm.stdin new file mode 100644 index 000000000000..1538fd0fb587 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/nl/atm.stdin @@ -0,0 +1,2 @@ +&atm_inparm +/ diff --git a/share/csm_share/test/old_unit_testers/nl/cpl.stdin b/share/csm_share/test/old_unit_testers/nl/cpl.stdin new file mode 100644 index 000000000000..a60131ff07cd --- /dev/null +++ b/share/csm_share/test/old_unit_testers/nl/cpl.stdin @@ -0,0 +1,2 @@ +&cpl_inparm +/ diff --git a/share/csm_share/test/old_unit_testers/nl/ice.stdin b/share/csm_share/test/old_unit_testers/nl/ice.stdin new file mode 100644 index 000000000000..0b67c0072865 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/nl/ice.stdin @@ -0,0 +1,2 @@ +&ice_inparm +/ diff --git a/share/csm_share/test/old_unit_testers/nl/lnd.stdin b/share/csm_share/test/old_unit_testers/nl/lnd.stdin new file mode 100644 index 000000000000..b10ac410610e --- /dev/null +++ b/share/csm_share/test/old_unit_testers/nl/lnd.stdin @@ -0,0 +1,2 @@ +&lnd_inparm +/ diff --git a/share/csm_share/test/old_unit_testers/nl/ocn.stdin b/share/csm_share/test/old_unit_testers/nl/ocn.stdin new file mode 100644 index 000000000000..70ab49fa4611 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/nl/ocn.stdin @@ -0,0 +1,2 @@ +&ocn_inparm +/ diff --git a/share/csm_share/test/old_unit_testers/run_dshr_bundle_test b/share/csm_share/test/old_unit_testers/run_dshr_bundle_test new file mode 100755 index 000000000000..7ac6300c3e53 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/run_dshr_bundle_test @@ -0,0 +1,96 @@ +#!/bin/csh +# +# Script to run the dshr_bundle unit test. +# +#----------------------------------------------------------------------- +# NCAR IBM SP: bluevista +# Usage: env CSMBL_ROOT= bsub < run_dshr_bundle +#----------------------------------------------------------------------- +## Setting LSF options for batch queue submission. +#BSUB -a poe # use poe for multiprocessing +## Number of tasks and tasks per node (CHANGE THIS IF YOU TURN smp on) +#BSUB -n 1 # total number of MPI-tasks (processors) needed +#BSUB -R "span[ptile=2]" # max number of tasks (MPI) per node +#BSUB -o out.%J # output filename +#BSUB -e out.%J # error filename +#BSUB -q share # queue +#BSUB -W 1:10 # wall clock limit +#BSUB -P 93300006 # Project number to charge to (MAKE SURE YOU CHANGE THIS!!!) + +# +#----------------------------------------------------------------------- +# CGD Linux cluster : bangkok +# Usage: env CSMBL_ROOT= qsub run_dshr_bundle +#----------------------------------------------------------------------- +# Name of the queue (CHANGE THIS if needed) +#PBS -q long +# Number of nodes (CHANGE THIS if needed) +#PBS -l nodes=2:ppn=2:ecc +# output file base name +#PBS -N bundle.linux.log +# Put standard error and standard out in same file +#PBS -j oe +# Export all Environment variables +#PBS -V +# End of options +# + +# If batch go to work directory +if ( $?PBS_JOBID )then + cd ${PBS_O_WORKDIR} +endif + +if ( $?QSUB_REQID )then + cd ${QSUB_WORKDIR} +endif + +set uname = `uname -s` + +# +# Set make command to use +# +setenv GMAKE gmake +if ( $uname == "Darwin" ) setenv GMAKE "make FC=g95" + +# +# Set mpirun to use +# +if ( $uname == "Darwin" )then + set mpi = "mpirun -np 2" +else if ( $uname == "AIX" )then + set mpi = "mpirun.lsf" +else if ( $uname == "Linux" )then + set mpi = "/usr/local/mpich-1.2.7p1-pgi-pgcc-pghf-6.1-3/bin/mpirun -np 2" +endif + +# +# Standard tests +# +foreach opt ( "" "SPMD") + # Build + $GMAKE clean + set SPMD = "FALSE" + set optbld = "" + if ( $opt == "SPMD" ) set SPMD = "TRUE" + set optbld="SPMD=$SPMD" + # Run save output to log file + echo "Build with options: $optbld" + $GMAKE $optbld test_dshr_bundle >&! compile.log || exit 1 + echo "Run with options: $optbld" + if ( $SPMD == "TRUE" )then + $mpi test_dshr_bundle >! bundle.log + set retstatus=$status + else + test_dshr_bundle >! bundle.log + set retstatus=$status + endif + if ( $retstatus != 0 ) then + echo "Error -- run status returns error: $retstatus" + grep "All expected tests ran successfully" bundle.log + if ( $status != 0 ) exit 2 + endif +end + +$GMAKE clean +\rm *.nc bundle.log* compile.log +echo "Testing successful\! PASS\!" diff --git a/share/csm_share/test/old_unit_testers/run_file_test b/share/csm_share/test/old_unit_testers/run_file_test new file mode 100755 index 000000000000..09975fcac8f1 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/run_file_test @@ -0,0 +1,68 @@ +#!/bin/csh +# +# Run test for shr_file_mod module. +# +#set echo +set cwd = `pwd` +echo "Make test" +setenv GMAKE gmake +if ( `uname -s` == "Darwin" ) setenv GMAKE "make FC=g95" +$GMAKE test_shr_file +if ( $status != 0 )then + echo "Test failed" + exit 999 +endif +echo "make stdio namelists" +foreach i ( "cpl" "ice" "ocn" ) + cat << EOF > ${i}_stdio.nml +&stdio + dir = "$cwd/nl" + stdout = "${i}.log" + stdin = "${i}.stdin" +/ +EOF +end +foreach i ( "atm" "lnd" ) + cat << EOF > ${i}_stdio.nml +&stdio + dir = "$cwd/nl" + stdout = "${i}.log" + nlfile = "${i}.stdin" +/ +EOF +end +echo "Softlink namelist files appropriately" +foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) + \ln -f -s $cwd/{$i}_stdio.nml $cwd/nl/. +end +echo "run test" +test_shr_file +cat test_shr_file.log +if ( $status != 0 )then + echo "Test failed" + exit 999 +endif +echo "Check test output.." +egrep "<<<<<<<>>>>>>>>>" test_shr_file.log +if ( $status == 0 )then + echo "Test failed test_shr_file.log has string expected for model log files"" + exit 999 +endif +foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) + grep "<<<<<<<>>>>>>>>>" nl/${i}.log + if ( $status != 0 )then + echo "Test failed $i log does not have expected string" + exit 999 + endif +end +echo "Test passed" +echo "clean up..." +$GMAKE clean +foreach i ( "atm" "lnd" "cpl" "ice" "ocn" ) + \rm ${i}_stdio.nml nl/${i}.log +end +echo +echo +echo + +echo "PASS" diff --git a/share/csm_share/test/old_unit_testers/test_mod.F90 b/share/csm_share/test/old_unit_testers/test_mod.F90 new file mode 100644 index 000000000000..967eee1c8906 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_mod.F90 @@ -0,0 +1,339 @@ +module test_mod + +use shr_kind_mod, only : SHR_KIND_R8 +use shr_sys_mod, only : shr_sys_abort + +implicit none + +public test_init +public test_is +public test_close +public test_final + +integer, save :: ntests = 0 +integer, save :: npass = 0 +integer, save :: num_expected = 0 +logical, save :: num_expected_given = .false. +character(*), parameter :: formatTest = '(A4, " ", i5.5, " - ", A)' +character(*), parameter :: formatArrayMatch = & + '(" (all ", i5, " values match)")' +character(*), parameter :: formatArray2DMatch = & + '(" (all ", i5, "x", i5, " values match)")' +character(*), parameter :: formatArrayMisMatch = & + '(" (only ", i5, " values of ", i5, " values match)")' +character(*), parameter :: formatArray2DMisMatch = & + '(" (only ", i5, " values of ", i5, "x", i5, " values match)")' +character(*), parameter :: formatRArrayClose = & + '(" (all ", i5, " values are within", 1pe9.1e2, " )")' +character(*), parameter :: formatRArrayNotClose = & + '(" (only ", i5, " values of ", i5, " values are within", 1pe9.1e2, " max diff= ", 1pe9.1e2, ")")' +character(*), parameter :: formatRClose = & + '(" ( value within", 1pe9.1e2, " )")' +character(*), parameter :: formatRNotClose = & + '(" ( value within", 1pe9.1e2, " diff= ", 1pe9.1e2, ")")' + +interface test_is + module procedure test_is_logical + module procedure test_is_logical1D + module procedure test_is_string + module procedure test_is_integer + module procedure test_is_integer1D + module procedure test_is_real1D + module procedure test_is_real2D + module procedure test_is_realScalar +end interface test_is + +interface test_close + module procedure test_close_real1D + module procedure test_close_realScalar +end interface test_close + +private test_is_logical +private test_is_string +private test_is_integer +private test_is_integer1D +private test_is_real1D +private test_is_realScalar +private test_close_real1D + +contains + + +subroutine test_init( num_expected_tests ) + integer, intent(IN), optional :: num_expected_tests + + if ( present(num_expected_tests) ) then + num_expected = num_expected_tests + num_expected_given = .true. + write(*,formatTest) "1...", num_expected, "expected tests" + write(*,*) + end if + +end subroutine test_init + +subroutine test_is_logical( pass, description ) + + implicit none + + logical, intent(IN) :: pass ! If matches or not + character(*), intent(IN) :: description ! description of test + + character(4) :: status + + ntests = ntests + 1 + if ( pass )then + npass = npass + 1 + status = "PASS" + else + status = "FAIL" + end if + write(*,formatTest) status, ntests, trim(description) + +end subroutine test_is_logical + +subroutine test_is_logical1D( value, expected, description ) + + implicit none + + logical, intent(IN) :: value(:) ! test value + logical, intent(IN) :: expected(:) ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + integer :: nsize, nmatch + character(256) :: descrip + + nsize = size(value) + if ( all(value .eqv. expected) )then + pass = .true. + write(descrip,formatArrayMatch) nsize + else + nmatch = count(value .eqv. expected) + write(descrip,formatArrayMisMatch) nmatch, nsize + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_is_logical1D + + +subroutine test_is_string( value, expected, description ) + + implicit none + + character(len=*), intent(IN) :: value + character(len=*), intent(IN) :: expected + character(len=*), intent(IN) :: description ! description of test + + + logical :: pass ! If matches or not + + character(4) :: status + + if ( trim(value) == trim(expected) )then + pass = .true. + else + pass = .false. + end if + ntests = ntests + 1 + if ( pass )then + npass = npass + 1 + status = "PASS" + else + status = "FAIL" + end if + write(*,formatTest) status, ntests, trim(description) + +end subroutine test_is_string + +subroutine test_is_integer( value, expected, description ) + integer, intent(IN) :: value ! test value + integer, intent(IN) :: expected ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + + if ( value == expected )then + pass = .true. + else + pass = .false. + end if + call test_is_logical( pass, description ) + +end subroutine test_is_integer + +subroutine test_is_integer1D( value, expected, description ) + integer, intent(IN) :: value(:) ! test value + integer, intent(IN) :: expected(:) ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + integer :: nsize, nmatch + character(256) :: descrip + + nsize = size(value) + if ( all(value == expected) )then + pass = .true. + write(descrip,formatArrayMatch) nsize + else + nmatch = count(value == expected) + write(descrip,formatArrayMisMatch) nmatch, nsize + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_is_integer1D + +subroutine test_is_real1D( value, expected, description ) + real(SHR_KIND_R8), intent(IN) :: value(:) ! test value + real(SHR_KIND_R8), intent(IN) :: expected(:) ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + integer :: nsize, nmatch + character(256) :: descrip + + nsize = size(value) + if ( all(value == expected) )then + pass = .true. + write(descrip,formatArrayMatch) nsize + else + nmatch = count(value == expected) + write(descrip,formatArrayMisMatch) nmatch, nsize + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_is_real1D + +subroutine test_is_real2D( value, expected, description ) + real(SHR_KIND_R8), intent(IN) :: value(:,:) ! test value + real(SHR_KIND_R8), intent(IN) :: expected(:,:) ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + integer :: nsize1, nsize2, nmatch + character(256) :: descrip + + nsize1 = size(value,1) + nsize2 = size(value,2) + if ( all(value == expected) )then + pass = .true. + write(descrip,formatArray2DMatch) nsize1, nsize2 + else + nmatch = count(value == expected) + write(descrip,formatArray2DMisMatch) nmatch, nsize1, nsize2 + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_is_real2D + +subroutine test_is_realScalar( value, expected, description ) + real(SHR_KIND_R8), intent(IN) :: value ! test value + real(SHR_KIND_R8), intent(IN) :: expected ! expected value + character(*), intent(IN) :: description ! description of test + + logical :: pass + + if ( value == expected )then + pass = .true. + else + pass = .false. + end if + call test_is_logical( pass, description ) + +end subroutine test_is_realScalar + +subroutine test_close_real1D( value, expected, eps, description, rel_diff ) + real(SHR_KIND_R8), intent(IN) :: value(:) ! test value + real(SHR_KIND_R8), intent(IN) :: expected(:) ! expected value + real(SHR_KIND_R8), intent(IN) :: eps ! epsilon -- how close to be within + character(*), intent(IN) :: description ! description of test + logical, optional, intent(IN) :: rel_diff ! if should do relative difference or not + + logical :: pass, lreldiff + integer :: nsize, nmatch, i, n0(1), nf(1) + real(SHR_KIND_R8) :: within, diff + character(256) :: descrip + + lreldiff = .false. + if ( present(rel_diff) ) lreldiff = rel_diff + nsize = size(value) + if ( nsize /= size(expected) )then + call shr_sys_abort( "size of value and expected array is different" ) + end if + if ( any(lbound(value) /= lbound(expected)) )then + call shr_sys_abort( "lower bound of value and expected array is different" ) + end if + nmatch = 0 + n0 = lbound(value) + nf = ubound(value) + within = abs(value(n0(1)) - expected(n0(1))) + if ( lreldiff .and. within > 0.0_SHR_KIND_R8 ) within = within / max( abs(value(n0(1))), abs(expected(n0(1))) ) + do i = n0(1), nf(1) + diff = abs(value(i) - expected(i)) + if ( lreldiff .and. diff > 0.0_SHR_KIND_R8 ) diff = diff / max(abs(value(i)),abs(expected(i)) ) + within = max( within, diff ) + if ( diff <= eps ) nmatch = nmatch + 1 + end do + if( nmatch == nsize )then + write(descrip,formatRArrayClose) nsize, eps + pass = .true. + else + write(descrip,formatRArrayNotClose) nmatch, nsize, eps, within + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_close_real1D + +subroutine test_close_realScalar( value, expected, eps, description ) + real(SHR_KIND_R8), intent(IN) :: value ! test value + real(SHR_KIND_R8), intent(IN) :: expected ! expected value + real(SHR_KIND_R8), intent(IN) :: eps ! epsilon -- how close to be within + character(*), intent(IN) :: description ! description of test + + logical :: pass + real(SHR_KIND_R8) :: diff + character(256) :: descrip + + diff = abs(value - expected) + if ( diff <= eps ) then + write(descrip,formatRClose) eps + pass = .true. + else + write(descrip,formatRNotClose) eps, diff + pass = .false. + end if + call test_is_logical( pass, trim(description)//trim(descrip) ) + +end subroutine test_close_realScalar + +subroutine test_final( PassStatus ) + + logical, intent(OUT), optional :: PassStatus + + character(4) :: status + character(50) :: desc + + write(*,*) + status = "PASS" + if ( present(PassStatus) ) PassStatus = .true. + desc = "All expected tests ran successfully" + if ( num_expected_given .and. ntests /= num_expected )then + status = "FAIL" + desc = "Different number of tests than expected" + if ( present(PassStatus) ) PassStatus = .false. + end if + if ( npass /= ntests )then + status = "FAIL" + if ( present(PassStatus) ) PassStatus = .false. + write(desc,'(A,i3,A)') "Not all tests passed (", & + ntests-npass, " tests failed)" + end if + write(*,formatTest) status, ntests, "tests run -- "//desc + +end subroutine test_final + +end module test_mod diff --git a/share/csm_share/test/old_unit_testers/test_shr_file.F90 b/share/csm_share/test/old_unit_testers/test_shr_file.F90 new file mode 100644 index 000000000000..c3f92af6b33f --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_file.F90 @@ -0,0 +1,220 @@ +program test_shr_file +use shr_sys_mod, only: shr_sys_abort, shr_sys_system +use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit, & + shr_file_chDir, shr_file_chStdIn, shr_file_chStdOut +! +! unit test of the shr_file_mod module +! +write(6,*) 'Test file get/put: ' +call test_getput() + +write(6,*) 'Test units: ' +call test_unit() + +! Test the stdio series of subroutines +write(6,*) 'Test stdio: ' +call test_stdio() + +stop "Tests Pass" + +contains + +subroutine test_stdio() +use shr_sys_mod, only: shr_sys_getenv, shr_sys_chdir +integer, parameter :: nModels = 5 +character(len=3), parameter :: models(nmodels) = (/"atm", "lnd", "ice", "ocn", "cpl"/) +character(len=256) :: nlfile +character(len=256) :: pwd, cwd +character(len=256), parameter :: logfile = "test_shr_file.log" +integer :: i, unit, j +integer :: rcode +logical :: exists +namelist /atm_inparm/ j +namelist /lnd_inparm/ j +namelist /ocn_inparm/ j +namelist /ice_inparm/ j +namelist /cpl_inparm/ j + +call shr_sys_getenv( "pwd", pwd, rcode ) +call shr_sys_system( "/bin/rm "//trim(logfile), rcode ) +do i = 1, nModels + call shr_sys_system( "/bin/rm "//models(i)//".log", rcode ) + if ( i == 1 )then + open(6,file=logfile,status="new") + else + open(6,file=logfile,status="old", position="append") + end if + write(6,*) "test model: ", models(i) + write(6,*) "test chdir: " + call shr_file_chDir(models(i),rcodeOut=rcode) + if ( rcode /= 0 )then + call shr_sys_abort( "error: chDir returns error code" ) + end if + call shr_sys_getenv( "pwd", cwd, rcode ) + !if ( trim(pwd)//"/nl" /= cwd )then + ! write(6,*) 'pwd = ', trim(pwd) + ! write(6,*) 'cwd = ', trim(cwd) + ! call shr_sys_abort( "error: chDir did not go to correct directory" ) + !end if + write(6,*) "test chstdin: " + if ( (models(i) == "atm") .or. (models(i) == "lnd") )then + call shr_file_chStdIn(models(i), NLFilename=nlfile,rcodeOut=rcode) + unit = shr_file_getUnit() + inquire(file=nlfile,exist=exists) + if ( .not. exists )then + call shr_sys_abort( "error: nlfilename does NOT exist: "//trim(nlfile) ) + end if + open(unit,file=trim(nlfile),status="old") + else + call shr_file_chStdIn(models(i),rcodeOut=rcode) + unit = 5 + end if + if ( rcode /= 0 )then + call shr_sys_abort( "error: chstdin returns error code" ) + end if + if ( models(i) == "atm" )then + read(unit,nml=atm_inparm,iostat=rcode) + else if ( models(i) == "lnd" )then + read(unit,nml=lnd_inparm,iostat=rcode) + else if ( models(i) == "ocn" )then + read(unit,nml=ocn_inparm,iostat=rcode) + else if ( models(i) == "ice" )then + read(unit,nml=ice_inparm,iostat=rcode) + else if ( models(i) == "cpl" )then + read(unit,nml=cpl_inparm,iostat=rcode) + end if + close(unit) + if ( rcode /= 0 )then + call shr_sys_abort( "error: reading namelist returns error code" ) + end if + write(6,*) "test chstdout: " + call shr_file_chStdOut(models(i),rcodeOut=rcode) + if ( rcode /= 0 )then + call shr_sys_abort( "error: chstdout returns error code" ) + end if + write(6,*) "<<<<<<<>>>>>>>>>" + call shr_sys_chdir("..",rcode) + close(6) +end do + +end subroutine test_stdio + +subroutine is_prefix( filename, expPrefix, nExpPrefix ) +use shr_file_mod, only: shr_file_queryPrefix, shr_file_noPrefix +character(*), intent(IN) :: filename +character(*), intent(IN) :: ExpPrefix +integer, intent(IN) :: nExpPrefix + +integer :: nPrefix +character(256) :: Prefix + +nPrefix = shr_file_queryPrefix( filename, prefix=prefix ) +if ( nPrefix /= nExpPrefix .or. trim(prefix) /= trim(ExpPrefix) )then + write(6,*) 'Prefix = ', trim(prefix), 'Expected = ', trim(ExpPrefix), " End" + write(6,*) 'N-Prefix = ', nPrefix, 'N-Expected = ', nExpPrefix + call shr_sys_abort( "error: wrong prefix type or wrong returned prefix length" ) +end if + +end subroutine is_prefix + +subroutine test_getput() +use shr_file_mod, only: shr_file_queryPrefix, shr_file_get, shr_file_put, shr_file_noPrefix, & + shr_file_nullPrefix, shr_file_cpPrefix, shr_file_mssPrefix, & + shr_file_hpssPrefix +character(256) :: filename +character(256) :: prefix +integer :: nprefix + + +filename = "/long:directory_d/sub-directory::/file:with_colon.txt" +call is_prefix( filename, "", shr_file_noPrefix ) +filename = "cp:/longdirectory_d/sub-directory::/file:with_colon.txt" +call is_prefix( filename, "cp:", shr_file_cpPrefix ) +filename = "null:/long:directory_d/sub-directory::/file:with_colon.txt" +call is_prefix( filename, "null:", shr_file_nullPrefix ) +filename = "mss:/long:directory_d/sub-directory::/file:with_colon.txt" +call is_prefix( filename, "mss:", shr_file_mssPrefix ) +filename = "hpss:/long:directory_d/sub-directory::/file:with_colon.txt" +call is_prefix( filename, "hpss:", shr_file_hpssPrefix ) +filename = "file:with_colon.txt" +call is_prefix( filename, "", shr_file_noPrefix ) + +end subroutine test_getput + +subroutine test_unit() +integer, parameter :: mxUnits = 89 +integer :: unit(mxUnits) +integer, parameter :: mxRandom = 5 +integer, parameter :: Random(mxRandom) = (/ 4, 36, 91, 92, 95 /) +integer, parameter :: mxTaken = 30 +integer, parameter :: taken(mxTaken) = (/ 3, 9, 11, 21, 23, 25, 28, 30, 33, 35, & + 37, 39, 40, 42, 43, 45, 49, 52, 53, 55, & + 60, 61, 63, 64, 65, 66, 67, 69, 80, 82 /) +integer :: i, j +logical :: opened + +! Test the get unit number routine +do k = 1, 2 ! Loop through this series twice to make sure things ok + ! Open some random unit numbers + do i = 1, mxRandom + call open_file(random(i)) + end do + ! First take a bunch of units with explicit unit numbers + do i = 1, mxTaken + j = shr_file_getUnit( taken(i) ) + call open_file(taken(i)) + if ( j /= taken(i) )then + call shr_sys_abort( "error: get unit did NOT grab the correct unit" ) + end if + end do + ! Now loop through and take all other unit numbers + do i = 1, mxUnits-mxTaken-mxRandom + unit(i) = shr_file_getUnit() + inquire(unit(i), opened=opened ) + if ( opened )then + call shr_sys_abort( "error: get unit got a unit already opened" ) + end if + call open_file(unit(i)) + do j = 1, mxTaken + if ( unit(i) == taken(j) )then + call shr_sys_abort( "error: get unit got a unit already taken" ) + end if + end do + do j = 1, i-1 + if ( unit(i) == unit(j) )then + call shr_sys_abort( "error: get unit got a unit already taken" ) + end if + end do + end do + ! Free units taken + do i = 1, mxUnits-mxTaken-mxRandom + call close_file(unit(i) ) + call shr_file_freeUnit( unit(i) ) + end do + do i = 1, mxTaken + call close_file(taken(i) ) + call shr_file_freeUnit( taken(i) ) + end do + do i = 1, mxRandom + call close_file(random(i)) + end do +end do +end subroutine test_unit + +subroutine open_file(unit) +integer :: unit +character(len=256) :: tmp + +write(6,*) "take unit", unit +write(tmp,"('tmp',i3.3,'.dat')") unit +open(unit, file=tmp, status="new") +end subroutine open_file + +subroutine close_file(unit) +integer :: unit +close(unit,status="delete") +write(6,*) "free unit", unit +end subroutine close_file + + +end program test_shr_file diff --git a/share/csm_share/test/old_unit_testers/test_shr_log.F90 b/share/csm_share/test/old_unit_testers/test_shr_log.F90 new file mode 100644 index 000000000000..fe8b7c784920 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_log.F90 @@ -0,0 +1,28 @@ +program test_shr_log + use test_mod, only : test_init, test_final + implicit none + + call test_init + + call test_shr_log_errMsg + + call test_final + +contains + + subroutine test_shr_log_errMsg + use shr_log_mod + use test_mod + + implicit none + + character(len=256) :: my_result + + my_result = shr_log_errMsg('myfile.f90', 42) + + call test_is(my_result, "ERROR in myfile.f90 at line 42", "shr_log_errMsg: basic test") + + end subroutine test_shr_log_errMsg +end program test_shr_log + + diff --git a/share/csm_share/test/old_unit_testers/test_shr_mpi.F90 b/share/csm_share/test/old_unit_testers/test_shr_mpi.F90 new file mode 100644 index 000000000000..6e47a27a1fb4 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_mpi.F90 @@ -0,0 +1,291 @@ +module test_shr_mpi_mod + use shr_mpi_mod, only: shr_mpi_gathScatVInit, & + shr_mpi_gatherV, & + shr_mpi_scatterv, & + shr_mpi_commrank, & + shr_mpi_chkerr, & + shr_mpi_commsize, & + shr_mpi_send, & + shr_mpi_recv, & + shr_mpi_barrier + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_sys_mod, only: shr_sys_abort + implicit none +#include + + private + + public :: test_gathScat + public :: test_gathScatDiffPES + + contains + +logical function test_gathScat( mpicom, rootid, locArr ) + use shr_kind_mod, only: SHR_KIND_IN + use shr_const_mod, only: SHR_CONST_SPVAL + implicit none + integer(SHR_KIND_IN), intent(IN) :: mpicom + integer(SHR_KIND_IN), intent(IN) :: rootid + real(r8), pointer :: locArr(:) + + real(r8), pointer :: glob1DArr(:), glob1DArrBack(:) + integer(SHR_KIND_IN), pointer :: globSize(:), displs(:) + integer(SHR_KIND_IN), pointer :: globSizeBack(:), displsBack(:) + real(r8), pointer :: locArrBack(:) + integer :: rank, npes, ierr + logical, pointer :: results(:) + + if ( .not. associated(locArr) )then + test_gathScat = .false. + return + end if + allocate( locArrBack(size(locArr)) ) + locArrBack(:) = SHR_CONST_SPVAL + call shr_mpi_gathScatvInit( mpicom, rootid, locArr, glob1DArr, globSize, displs ) + call shr_mpi_gathScatvInit( mpicom, rootid, locArrBack, glob1DArrBack, & + globSizeBack, displsBack ) + call shr_mpi_gatherv( locarr, size(locArr), glob1DArr, globSize, displs, rootid, & + mpicom ) + call shr_mpi_commrank( mpicom, rank ) + call shr_mpi_commsize( mpicom, npes ) + if ( rank == rootid ) glob1DArrBack(:) = glob1DArr(:) + call shr_mpi_scatterv( locarrBack, size(locArrBack), glob1DArrBack, globSizeBack, & + displsBack, rootid, mpicom ) + ! Test that original local array and array from gather/scatter are same + if ( all(locArr == locArrBack) .and. all(locArrBack /= SHR_CONST_SPVAL) )then + test_gathScat = .true. + else + test_gathScat = .false. + end if + ! Now check that global arrays are the same after the gather + if ( rank == rootid .and. test_gathScat ) glob1DArrBack(:) = SHR_CONST_SPVAL + call shr_mpi_gatherv( locarr, size(locArr), glob1DArrBack, globSize, displs, rootid, & + mpicom ) + if ( rank == rootid .and. test_gathScat )then + if ( all(glob1DArr(:) == glob1DArrBack(:)) .and. all(glob1DArrBack(:) /= SHR_CONST_SPVAL) )then + test_gathScat = .true. + else + test_gathScat = .false. + end if + end if + deallocate( glob1DArr, globSize, displs ) + deallocate( glob1DArrBack, globSizeBack, displsBack ) + return +end function test_gathScat + +logical function test_gathScatDiffPES( mpicom, mpicom2, rootid, locArr ) + use shr_kind_mod, only: SHR_KIND_IN + use shr_const_mod, only: SHR_CONST_SPVAL + implicit none + integer(SHR_KIND_IN), intent(IN) :: mpicom + integer(SHR_KIND_IN), intent(IN) :: mpicom2 + integer(SHR_KIND_IN), intent(IN) :: rootid + real(r8), pointer :: locArr(:) + + real(r8), pointer :: glob1DArr(:) + integer(SHR_KIND_IN), pointer :: globSize(:), displs(:) + integer :: rank, npes, ierr, rank2, npes2, nsize, i + integer, pointer :: lsize(:) + logical, pointer :: results(:) + real(r8), pointer :: locArr2(:) + real(r8), pointer :: glob1DArr2(:) + integer(SHR_KIND_IN), pointer :: globSize2(:), displs2(:) + + if ( .not. associated(locArr) )then + test_gathScatDiffPES = .false. + return + end if + ! First gather the local array into a global array that you keep + call shr_mpi_gathScatvInit( mpicom, rootid, locArr, glob1DArr, globSize, displs ) + call shr_mpi_gatherv( locarr, size(locArr), glob1DArr, globSize, displs, rootid, & + mpicom ) + ! Then scatter/gather using the other communicator -- make sure global array identical + call shr_mpi_commrank( mpicom, rank ) + if ( mpicom2 /= MPI_COMM_NULL )then + call shr_mpi_commsize( mpicom2, npes2 ) + ! Figure out size for each local array and send to each processor in group + if ( rank == rootid )then + nsize = size(glob1DArr) / npes2 + allocate( lsize(0:npes2-1) ) + lsize(0:npes2-2) = nsize + lsize(npes2-1) = size(glob1DArr) - sum(lsize(0:npes2-2)) + do i = 1, npes2-1 + write(6,*) "lsize, peid = ", lsize(i), i + call shr_mpi_send( lsize(i), i, 1055, mpicom2 ) + end do + deallocate( lsize ) + else + call shr_mpi_recv( nsize, rootid, 1055, mpicom2 ) + end if + allocate( locArr2(nsize) ) + call shr_mpi_gathScatvInit( mpicom2, rootid, locArr2, glob1DArr2, globSize2, & + displs2 ) + call shr_mpi_scatterv( locarr2, size(locArr2), glob1DArr, globSize2, & + displs2, rootid, mpicom2 ) + glob1DArr2(:) = SHR_CONST_SPVAL + call shr_mpi_gatherv( locarr2, size(locArr2), glob1DArr2, globSize2, displs2, & + rootid, mpicom2 ) + call shr_mpi_commrank( mpicom, rank2 ) + if ( (rank == rootid) .and. (rank2 == rootid) )then + if ( all(glob1DArr(:) == glob1DArr2(:)) .and. & + all(glob1DArr2(:) /= SHR_CONST_SPVAL) )then + test_gathScatDiffPES = .true. + else + test_gathScatDiffPES = .false. + end if + end if + deallocate( glob1DArr2, globSize2, displs2 ) + end if + deallocate( glob1DArr, globSize, displs ) + return +end function test_gathScatDiffPES + +end module test_shr_mpi_mod + +program test_shr_mpi + + use test_shr_mpi_mod, only: test_gathScat, test_gathScatDiffPES + use shr_mpi_mod, only: shr_mpi_init, & + shr_mpi_finalize, & + shr_mpi_commrank, & + shr_mpi_commsize, & + shr_mpi_chkerr, & + shr_mpi_barrier + use shr_kind_mod, only: r8 => SHR_KIND_R8 + use shr_sys_mod, only: shr_sys_abort, shr_sys_flush + implicit none +#include + integer :: mpicom = MPI_COMM_WORLD + integer, parameter :: rootid = 0 + real(r8), pointer :: locArr(:) + integer :: i, gsize, rank, npes, npe1, npe2 + integer, pointer :: seed(:) + integer :: seedSize + character(len=80) :: TestType + real(r8) :: x + logical :: masterproc + integer :: mpicom1, mpicom2 + integer :: mpigrp, mpigrp1, mpigrp2, ierr + + call shr_mpi_init( ) + call shr_mpi_commrank( mpicom, rank ) + call shr_mpi_commsize( mpicom, npes ) + masterproc = rank == rootid + if ( masterproc ) write(6,*) "shr_mpi_mod unit test" + call random_seed( size=seedSize ) + allocate( seed(seedSize) ) + seed(:) = rank*1000 + 1444 + call random_seed( put=seed ) + deallocate( seed ) + ! Get communicators for a subset of the processors + if ( npes > 3 )then + ! Create new groups of 1 and 2 processors + ! Must include rank 0 in both... + call mpi_comm_group( mpicom, mpigrp, ierr ) + call shr_mpi_chkerr( ierr, "Error getting mpi group" ) + call mpi_group_incl( mpigrp, 1, (/0/), mpigrp1, ierr ) + call shr_mpi_chkerr( ierr, "Error getting mpi group-1" ) + call mpi_comm_create( mpicom, mpigrp1, mpicom1, ierr ) + call shr_mpi_chkerr( ierr, "Error creating new comm group with 1 processor" ) + call mpi_group_incl( mpigrp, 2, (/0,2/), mpigrp2, ierr ) + call shr_mpi_chkerr( ierr, "Error getting mpi group-2" ) + call mpi_comm_create( mpicom, mpigrp2, mpicom2, ierr ) + call shr_mpi_chkerr( ierr, "Error creating new comm group with 2 processors" ) + ! Initialize gather/scatter for new communicator groups + call shr_mpi_barrier( mpicom ) + if ( mpicom1 /= MPI_COMM_NULL )then + call shr_mpi_barrier( mpicom1 ) + call shr_mpi_commsize( mpicom1, npe1 ) + if ( npe1 /= 1 ) call shr_sys_abort( "mpicom1 wrong size" ) + end if + if ( mpicom2 /= MPI_COMM_NULL )then + call shr_mpi_barrier( mpicom2 ) + call shr_mpi_commsize( mpicom2, npe2 ) + if ( npe2 /= 2 ) call shr_sys_abort( "mpicom2 wrong size" ) + end if + end if + do i = 1, 4 + if ( i == 1 )then + TestType = "same sizes, random values" + gsize = 10 + call fillArrayRandom( gsize, locArr ) + else if ( i == 2 )then + TestType = "same sizes, ordered values" + gsize = 100 + call fillArrayOrdered( gsize, locArr, rank ) + else if ( i == 3 )then + TestType = "random sizes, random values" + call random_number( x ) + gsize = nint( x*100._r8 ) + 100 + call fillArrayRandom( gsize, locArr ) + else if ( i == 4 )then + TestType = "random sizes, ordered values" + call random_number( x ) + gsize = nint( x*200._r8 ) + 50 + call fillArrayOrdered( gsize, locArr, rank ) + else + call shr_sys_abort( "Bad index number for test" ) + end if + if ( masterproc ) write(6,*) "Gather/scatter test for: ", trim(TestType) + write(6,*) 'rank, size, locarr = ', rank, gsize, locArr + call shr_sys_flush(6) + if ( .not. test_gathScat( mpicom, rootid, locArr ) )then + call shr_sys_abort( "Error in doing scatter/gather" ) + end if + call shr_mpi_barrier( mpicom ) + if ( masterproc ) write(6,*) "PASS" + if ( npes > 3 )then + if ( masterproc ) write(6,*) "Gather/scatter test on mpicom1 for: ", trim(TestType) + call shr_sys_flush(6) + if ( .not. test_gathScatDiffPES( mpicom, mpicom1, rootid, locArr ) )then + call shr_sys_abort( "Error in reconstructing array with mpicom1" ) + end if + call shr_mpi_barrier( mpicom ) + if ( masterproc ) write(6,*) "PASS" + call shr_mpi_barrier( mpicom ) + if ( masterproc ) write(6,*) "PASS" + if ( masterproc ) write(6,*) "Gather/scatter test on mpicom2 for: ", trim(TestType) + call shr_sys_flush(6) + if ( .not. test_gathScatDiffPES( mpicom, mpicom2, rootid, locArr ) )then + call shr_sys_abort( "Error in reconstructing array with mpicom2" ) + end if + call shr_mpi_barrier( mpicom ) + if ( masterproc ) write(6,*) "PASS" + end if + deallocate( locArr ) + end do + call shr_mpi_finalize( ) + if ( masterproc ) write(6,*) "SUCCESS!" + if ( masterproc ) write(6,*) "PASS" + +contains + +subroutine fillArrayRandom( gsize, locArr ) + integer, intent(in) :: gsize + real(r8), pointer :: locArr(:) + + real(r8) :: x + integer :: g + + allocate( locArr(gsize) ) + do g = 1, gsize + call random_number( x ) + locArr(g) = x * 1000.0_r8 + end do +end subroutine fillArrayRandom + +subroutine fillArrayOrdered( gsize, locArr, rank ) + integer, intent(in) :: gsize + integer, intent(in) :: rank + real(r8), pointer :: locArr(:) + + real(r8) :: x + integer :: g + + allocate( locArr(gsize) ) + do g = 1, gsize + locArr(g) = real( g, r8 ) + rank*1000.0_r8 + end do +end subroutine fillArrayOrdered + +end program test_shr_mpi diff --git a/share/csm_share/test/old_unit_testers/test_shr_orb.F90 b/share/csm_share/test/old_unit_testers/test_shr_orb.F90 new file mode 100644 index 000000000000..85f9e251ee01 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_orb.F90 @@ -0,0 +1,47 @@ + program test_shr_orb +! +! Simple unit-test program for the shr_orb_mod module. +! +! Erik Kluzek +! +! $Id: test_shr_orb.F90 7482 2007-11-07 20:54:58Z erik $ +! + use shr_kind_mod, only: SHR_KIND_R8, SHR_KIND_IN + use shr_orb_mod, only: shr_orb_cosz, shr_orb_params, shr_orb_decl, shr_orb_print + implicit none + integer, parameter :: nyears = 5 + integer, parameter :: ndays = 5 + real (SHR_KIND_R8), parameter :: jday(ndays) = & + (/ 0.0_SHR_KIND_R8, 0.25_SHR_KIND_R8, 0.5_SHR_KIND_R8, 180.0_SHR_KIND_R8, 365.0_SHR_KIND_R8 /) ! Julian cal day (1.xx to 365.xx) + real (SHR_KIND_R8) :: lat = 42.0_SHR_KIND_R8 ! Centered latitude (radians) + real (SHR_KIND_R8) :: lon = 0.0_SHR_KIND_R8 ! Centered longitude (radians) + real (SHR_KIND_R8) :: declin ! Solar declination (radians) + real (SHR_KIND_R8) :: eccen ! orbital eccentricity + real (SHR_KIND_R8) :: obliq ! obliquity in degrees + real (SHR_KIND_R8) :: mvelp ! moving vernal equinox long + integer(SHR_KIND_IN), parameter :: iyear_AD(nyears) = & + (/-900000, -1650, 1950, 3600, 1000000/) + logical :: log_print = .true. ! Flags print of status/error + real (SHR_KIND_R8) :: obliqr ! Earths obliquity in rad + real (SHR_KIND_R8) :: lambm0 ! Mean long of perihelion at + ! vernal equinox (radians) + real (SHR_KIND_R8) :: mvelpp ! moving vernal equinox long + ! of perihelion plus pi (rad) + real (SHR_KIND_R8) :: cosz ! cosine of solar zenith angle + real (SHR_KIND_R8) :: eccf ! Earth-sun distance factor + integer i, j ! Indices + + print *, 'Test orbit calculation for ', nyears, ' years and ', ndays, ' days ' + do i = 1, nyears + call shr_orb_params( iyear_AD(i) , eccen , obliq , mvelp , & + & obliqr , lambm0 , mvelpp, log_print ) + call shr_orb_print( iyear_AD(i), eccen, obliq, mvelp ) + do j = 1, ndays + call shr_orb_decl(jday(j),eccen ,mvelpp ,lambm0 ,obliqr ,declin,eccf) + cosz = shr_orb_cosz(jday(j),lat,lon,declin) + print *, 'jday = ', jday(j), ' declin = ', declin, ' cosz = ', cosz + end do + end do + print *, 'PASS' + + end program test_shr_orb diff --git a/share/csm_share/test/old_unit_testers/test_shr_scam.F90 b/share/csm_share/test/old_unit_testers/test_shr_scam.F90 new file mode 100644 index 000000000000..631bbfbd2d14 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_scam.F90 @@ -0,0 +1,156 @@ +program test_shr_scam + + use shr_kind_mod, only : r8 => shr_kind_r8, CL => shr_kind_CL + use shr_scam_mod + use shr_mpi_mod + use shr_sys_mod + use shr_ncread_mod + use test_mod + use netcdf + use pio + implicit none +#include + + real(r8) :: targetLat, targetLon ! target latitude/longitude + real(r8) :: closeLat, closeLon ! close latitude/longitude + real(r8) :: expect(2) ! lat lon of expected + integer :: closeLatIdx, closeLonIdx ! indices of returned points + integer :: rc ! return code + integer :: ncid ! NetCDF id + integer :: npes, mype ! number of processors and my processor rank + character(len=CL) :: filename ! Filename to read + character(len=CL) :: badfilename ! bad Filename to read + character(len=CL) :: csmdata ! directory to inputdata + type(file_desc_t) :: pioid ! pio file ID + type (iosystem_desc_t), pointer :: piosystems + logical :: found ! if found or NOT + + call test_init( 22 ) + + ! Test simple valid tests + csmdata = "/fs/cgd/csm/inputdata" + filename = trim(csmdata)//"/lnd/clm2/surfdata/surfdata_1.9x2.5_simyr2000_c100505.nc" + write(6,*) "Test file: "//trim(filename) + targetLat = 45.0 + targetLon = 180.0 + expect = (/ 44.5263157894736d00, targetLon /) + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found ) + write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & + closeLat, closeLon + call test_is( found, "Test that a a simple call with filename works" ) + call test_close( expect, (/ closeLat, closeLon /), 1.e-13_r8, "Test lat/lon found correct" ) + expect = (/ closeLat, closeLon /) + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx ) + call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) + rc = nf90_open( filename, NF90_NOWRITE, ncid ) + if ( rc /= NF90_NOERR ) call shr_sys_abort( "NetCDF error opening file: "//trim(filename) ) + call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found ) + + call test_is( found, "Test that a a simple call to NetCDF id works" ) + call test_is( expect, (/ closeLat, closeLon /), "Test lat/lon found correct" ) + call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx ) + call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) + + if ( nf90_close( ncid ) /= NF90_NOERR ) call shr_sys_abort( "NetCDF error closing file" ) + write(6,*) "init mpi" + call shr_mpi_init( ) + call shr_mpi_commsize( MPI_COMM_WORLD, npes ) + call shr_mpi_commrank( MPI_COMM_WORLD, mype ) + write(6,*) "init PIO" + allocate( piosystems ) + call PIO_init(mype, MPI_COMM_WORLD, npes, 1, 1, pio_rearr_box, piosystems, base=0) + + rc = pio_openfile(piosystems, pioid, iotype_netcdf, filename, pio_nowrite) + if(rc/= PIO_NOERR) call shr_sys_abort( "PIO error opening file: "//trim(filename) ) + write(6,*) "PIO open on file" + call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found ) + + call test_is( found, "Test that a a simple call to the PIO interface works" ) + call test_is( expect, (/ closeLat, closeLon /), "Test lat/lon found correct" ) + call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx ) + call test_is( expect, (/ closeLat, closeLon /), "Test OK without found" ) + call pio_closefile(pioid) + + ! Test that can find periodic longitudes + targetLat = 1.0 + targetLon = 842.0 + expect = (/ 0.947368421052549d00, 122.5d00 /) + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( found, "Test that periodic longitude targets returns" ) + write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & + closeLat, closeLon + call test_close( expect, (/ closeLat, closeLon /), 1.e-13_r8, "Test lat/lon found correct" ) + expect = (/ closeLat, closeLon /) + filename = trim(csmdata)// & + "/lnd/clm2/initdata/clmi.BCN.2000-01-01_1.9x2.5_gx1v6_simyr2000_c100309.nc" + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( found, "Test that can find targets for clmi file" ) + call test_close( expect, (/ closeLat, closeLon /), 1.d-13, & + "Test that clmi targets same as other file" ) + ! Test abort tests + ! non-existant filename + call shr_ncread_setAbort( .false. ) + badfilename = "ZZTop.nc" + call shr_scam_getCloseLatLon( badfilename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that non existant file returns NOT found" ) + call shr_scam_getCloseLatLon( ncid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that non existant NetCDF ID returns NOT found" ) + call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that non existant PIO ID returns NOT found" ) + ! Test that targets outside of global lat/lons return not found + targetLat = -91.0 + targetLon = 0.0 + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that bad negative lat returns NOT found" ) + if ( found ) then + write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & + closeLat, closeLon + end if + targetLat = +91.0 + targetLon = 0.0 + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that bad positive lat returns NOT found" ) + if ( found ) then + write(6,*) "closest values to target of : ", targetLat, targetLon, " is: ", & + closeLat, closeLon + end if + targetLat = 45. + targetLon = 180. + filename = trim(csmdata)// & + "/lnd/clm2/snicardata/snicar_optics_5bnd_c090915.nc" + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that can NOT find targets for snicar optics file" ) + filename = trim(csmdata)// & + "/lnd/clm2/pftdata/pft-physiology.c110425.nc" + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that can NOT find targets for pft-phys file" ) + filename = trim(csmdata)// & + "/lnd/clm2/mappingdata/maps/10x15/map_0.5x0.5_landuse_to_10x15_aave_da_110307.nc" + call shr_scam_getCloseLatLon( filename, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call test_is( .not. found, "Test that can NOT find targets for mapping file" ) + rc = pio_openfile(piosystems, pioid, iotype_netcdf, filename, pio_nowrite) + if(rc/= PIO_NOERR) call shr_sys_abort( "PIO error opening file: "//trim(filename) ) + call shr_scam_getCloseLatLon( pioid, targetLat, targetLon, closeLat, closeLon, & + closeLatIdx, closeLonIdx, found=found, rc=rc ) + call pio_closefile(pioid) + call test_is( .not. found, "Test that can NOT find targets for PIO clmi file" ) + + call test_final() + +end diff --git a/share/csm_share/test/old_unit_testers/test_shr_streams.F90 b/share/csm_share/test/old_unit_testers/test_shr_streams.F90 new file mode 100644 index 000000000000..cc1fc802b9ff --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_streams.F90 @@ -0,0 +1,663 @@ +module streams_exp + use shr_kind_mod, only : SHR_KIND_CS, SHR_KIND_CL, SHR_KIND_CX + use shr_sys_mod, only : shr_sys_abort + use shr_file_mod, only : shr_file_getUnit, shr_file_freeUnit + use shr_stream_mod + + implicit none + + private + + public streams_exp_init + public streams_exp_set + public streams_exp_write_strm_txt + public is_streams_expected + + public streams_exp_data + + integer, public, parameter :: maxFiles = 2000 + + type streams_exp_data + character(SHR_KIND_CL) :: dataSource + character(SHR_KIND_CL) :: filePath + character(SHR_KIND_CX) :: fldListFile + character(SHR_KIND_CX) :: fldListModel + character(SHR_KIND_CL) :: domFilePath + character(SHR_KIND_CL) :: domFileName + character(SHR_KIND_CL) :: domTvarName + character(SHR_KIND_CL) :: domXvarName + character(SHR_KIND_CL) :: domYvarName + character(SHR_KIND_CL) :: domAreaName + character(SHR_KIND_CL) :: domMaskName + integer :: nfiles + character(SHR_KIND_CL) :: filenames(maxFiles) + end type streams_exp_data + +contains + +subroutine streams_exp_init( streams_exp ) + implicit none + type(streams_exp_data), intent(OUT) :: streams_exp + + integer :: i + + streams_exp%dataSource = "dataSource" + streams_exp%filePath = "filePath/" + streams_exp%fldListFile = "T:U" + streams_exp%fldListModel = "Temp:Wind_u" + streams_exp%domFilePath = "domFilePath/" + streams_exp%domFileName = "domFileName" + streams_exp%domTvarName = "time" + streams_exp%domXvarName = "xc" + streams_exp%domYvarName = "yc" + streams_exp%domAreaName = "area" + streams_exp%domMaskName = "mask" + streams_exp%nfiles = 1 + do i = 1, streams_exp%nfiles + write(streams_exp%filenames(i), '(a,i2.2)') "filename", i + end do +end subroutine streams_exp_init + +subroutine streams_exp_set( streams_exp, datasource, filePath, fldListfile, & + fldListModel, domFilePath, domFileName, domTvarName, & + domXvarName, domYvarName, domAreaName, domMaskName, & + nfiles, filenames ) + implicit none + type(streams_exp_data), intent(INOUT) :: streams_exp + character(*), intent(IN), optional :: dataSource + character(*), intent(IN), optional :: filePath + character(*), intent(IN), optional :: fldListFile + character(*), intent(IN), optional :: fldListModel + character(*), intent(IN), optional :: domFilePath + character(*), intent(IN), optional :: domFileName + character(*), intent(IN), optional :: domTvarName + character(*), intent(IN), optional :: domXvarName + character(*), intent(IN), optional :: domYvarName + character(*), intent(IN), optional :: domAreaName + character(*), intent(IN), optional :: domMaskName + integer , intent(IN), optional :: nfiles + character(*), intent(IN), optional :: filenames(:) + + integer :: i + + if ( present(dataSource) ) streams_exp%dataSource = datasource + if ( present(filePath) ) streams_exp%filePath = filePath + if ( present(fldListFile) ) streams_exp%fldListFile = fldListFile + if ( present(fldListModel) ) streams_exp%fldListModel = fldListModel + if ( present(domFilePath) ) streams_exp%domFilePath = domFilePath + if ( present(domFileName) ) streams_exp%domFileName = domFileName + if ( present(domTvarName) ) streams_exp%domTvarName = domTvarName + if ( present(domXvarName) ) streams_exp%domXvarName = domXvarName + if ( present(domYvarName) ) streams_exp%domYvarName = domYvarName + if ( present(domAreaName) ) streams_exp%domAreaName = domAreaName + if ( present(domMaskName) ) streams_exp%domMaskName = domMaskName + if ( present(nfiles) .and. present(filenames) )then + streams_exp%nfiles = nfiles + do i = 1, streams_exp%nfiles + streams_exp%filenames(i) = filenames(i) + end do + end if + +end subroutine streams_exp_set + + +subroutine streams_exp_write_strm_txt( stream_filename, streams_exp ) + use shr_string_mod, only : shr_string_listGetNum, shr_string_listGetName + use shr_sys_mod, only : shr_sys_system + implicit none + character(SHR_KIND_CL), intent(IN) :: stream_filename + type(streams_exp_data), intent(IN) :: streams_exp + + integer :: unit, n, rcode, nfModel, nfFile + character(SHR_KIND_CS) :: varModel, varFile + character(*), parameter :: sub = "write_streams_txt" + + unit = shr_file_getUnit( ) + write(*,*) "Write streams text file out to: ", trim(stream_filename) + open( unit, file=stream_filename, status="unknown") + + write(unit,*) "" + write(unit,*) " ", trim(streams_exp%dataSource) + write(unit,*) "" + write(unit,*) "" + write(unit,*) " " + write(unit,*) " ", trim(streams_exp%domTvarName), " time" + write(unit,*) " ", trim(streams_exp%domXvarName), " lon" + write(unit,*) " ", trim(streams_exp%domYvarName), " lat" + write(unit,*) " ", trim(streams_exp%domAreaName), " area" + write(unit,*) " ", trim(streams_exp%domMaskName), " mask" + write(unit,*) " " + write(unit,*) " " + write(unit,*) " ", trim(streams_exp%domFilePath) + write(unit,*) " " + write(unit,*) " " + write(unit,*) " ", trim(streams_exp%domFileName) + write(unit,*) " " + write(unit,*) "" + write(unit,*) "" + write(unit,*) " " + nfModel = shr_string_listGetNum( streams_exp%fldListModel ) + nfFile = shr_string_listGetNum( streams_exp%fldListFile ) + do n = 1, max( nfModel, nfFile ) + if ( n > nfFile ) then + varFile = " " + else + call shr_string_listGetName(streams_exp%fldListFile, n, varFile ) + end if + if ( n > nfModel ) then + varModel = " " + else + call shr_string_listGetName(streams_exp%fldListModel, n, varModel ) + end if + write(unit,*) & + " ", trim(varFile), " ", & + " ", trim(varModel) + end do + write(unit,*) " " + write(unit,*) " " + write(unit,'(A,A)') " ", trim(streams_exp%FilePath) + write(unit,*) " " + write(unit,*) " " + do n = 1, streams_exp%nfiles + write(unit,*) & + " ", trim(streams_exp%filenames(n)) + end do + write(unit,*) " " + write(unit,*) "" + close(unit) + call shr_file_freeUnit(unit) + call shr_sys_system( "cat "//trim(stream_filename), rcode ) + +end subroutine streams_exp_write_strm_txt + +logical function is_streams_expected( stream, streams_exp ) + implicit none + type(shr_stream_streamType) ,intent(in) :: stream ! stream in question + type(streams_exp_data), intent(IN) :: streams_exp + + character(SHR_KIND_CL) :: dataSource + character(SHR_KIND_CL) :: filePath + character(SHR_KIND_CX) :: fldListFile + character(SHR_KIND_CX) :: fldListModel + character(SHR_KIND_CL) :: domFilePath + character(SHR_KIND_CL) :: domFileName + character(SHR_KIND_CL) :: domTvarName + character(SHR_KIND_CL) :: domXvarName + character(SHR_KIND_CL) :: domYvarName + character(SHR_KIND_CL) :: domAreaName + character(SHR_KIND_CL) :: domMaskName + character(SHR_KIND_CL) :: filen, file_next, file_first + integer :: n + + is_streams_expected = .true. + + call shr_stream_getFileFieldList( stream, fldlistFile ) + call shr_stream_getModelFieldList( stream, fldlistModel ) + call shr_stream_getFilePath( stream, filePath ) + call shr_stream_getDataSource( stream, dataSource ) + call shr_stream_getDomainInfo( stream, domFilePath, domfileName, & + domTvarName, domXvarName, domYvarName, & + dommaskName, domareaName) + if ( trim(fldListFile) /= trim(streams_exp%fldListFile) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "fldListFile different" + if ( .not. is_streams_expected )then + write(*,*) trim(fldListFile) + write(*,*) trim(streams_exp%fldListFile) + end if + if ( trim(fldListModel) /= trim(streams_exp%fldListModel) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "fldListModel different" + if ( trim(filePath) /= trim(streams_exp%filePath) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "filePath different" + if ( trim(dataSource) /= trim(streams_exp%dataSource) ) & + is_streams_expected = .false. + if ( trim(domFilePath) /= trim(streams_exp%domFilePath) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domfilePath different" + if ( trim(domFileName) /= trim(streams_exp%domFileName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domfileName different" + if ( trim(domTvarName) /= trim(streams_exp%domTvarName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domTvarName different" + if ( trim(domXvarName) /= trim(streams_exp%domXvarName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domXvarName different" + if ( trim(domYvarName) /= trim(streams_exp%domYvarName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domYvarName different" + if ( trim(domAreaName) /= trim(streams_exp%domAreaName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domAreaName different" + if ( trim(domMaskName) /= trim(streams_exp%domMaskName) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "domMaskName different" + n = 1 + call shr_stream_getFirstFileName( stream, filen ) + file_first = filen + if ( trim(filen) /= trim(streams_exp%filenames(1)) ) is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "first file different" + do while( n < streams_exp%nfiles ) + n = n + 1 + call shr_stream_getNextFileName( stream, filen, file_next ) + if ( trim(file_next) /= trim(streams_exp%filenames(n)) ) & + is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "next file different" + if ( trim(file_next) == trim(file_first) ) is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "Too few files" + filen = file_next + end do + call shr_stream_getNextFileName( stream, filen, file_next ) + if ( trim(file_next) /= trim(file_first) ) is_streams_expected = .false. + if ( .not. is_streams_expected ) write(*,*) "too many files" + +end function is_streams_expected + +end module streams_exp + +program test_shr_streams + + use shr_kind_mod + use shr_string_mod + use shr_sys_mod + use shr_stream_mod + use streams_exp + use test_mod + + implicit none + + type(shr_stream_streamType), pointer :: streams(:) ! stream in question + type(shr_stream_streamType), pointer :: streams2(:) ! stream in question + integer :: yearFirst, yearLast, yearAlign + character(SHR_KIND_CL) :: stream_filename = "sfile.txt" + character(SHR_KIND_CL) :: rest_filename = "sfile_rest.nc" + character(SHR_KIND_CL) :: test_descrip, filenames1(maxFiles) + type(streams_exp_data) :: stream_exp ! stream in question + integer :: series, n, i + integer, pointer :: expected(:), value(:) + character(SHR_KIND_CS) :: clmncep(12) = (/ & + "clmforc.Qian.c2006.T62.Solr.2003-01.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-02.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-03.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-04.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-05.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-06.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-07.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-08.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-09.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-10.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-11.nc", & + "clmforc.Qian.c2006.T62.Solr.2003-12.nc" & + /) + character(SHR_KIND_CS) :: clmncepTPQW(12) = (/ & + "clmforc.Qian.c2006.T62.TPQW.2003-01.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-02.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-03.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-04.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-05.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-06.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-07.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-08.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-09.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-10.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-11.nc", & + "clmforc.Qian.c2006.T62.TPQW.2003-12.nc" & + /) + character(SHR_KIND_CS) :: filenames2(12) + integer :: mDateIn, SecIn, year, month, rcode, exp_int, nfiles + integer :: mDateLB, dDateLB, secLB, n_lb + integer :: mDateUB, dDateUB, secUB, n_ub + character(SHR_KIND_CL) :: fileLB, fileUB + integer :: num_series, num_fail + integer, parameter :: bogus_TEST = 1, & + CLMNCEP_TEST = 2, & + CLMNCEP_ALOGO_TEST = 3, & + GISS_TEST = 4, & + CAMHIST_TEST = 5 + +#ifdef LINUX + num_series = CLMNCEP_ALOGO_TEST +#else + num_series = CAMHIST_TEST +#endif + num_fail = 3 + 12 + call test_init( 2 + (num_series-1)*3 + num_fail ) + do series = 2, num_series + yearAlign = 1 + yearFirst = 1 + yearLast = 1 + allocate( streams(1) ) + allocate( streams2(1) ) + write(*,*) "Initialize expected streams" + call streams_exp_init( stream_exp ) + if ( series == bogus_TEST )then + test_descrip = "bogus" + else if ( series == CLMNCEP_TEST )then + test_descrip = "CLMNCEP" + call streams_exp_set( stream_exp, datasource="CLMNCEP", & + fldListfile ="FSDS", & + fldListModel="fsds", & + filepath= & + "/fs/cgd/csm/inputdata/atm/datm7/atm_forcing.datm7.Qian.T62.c080727/Solar6Hrly", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & + domfilename="domain.T62.050609.nc", & + nfiles=12, filenames=clmncep(1:12) ) + yearAlign = 2003 + yearFirst = 2003 + yearLast = 2003 + else if ( series == CLMNCEP_ALOGO_TEST )then + test_descrip = "CLMNCEP-ALOGO" + call streams_exp_set( stream_exp, datasource="CLMNCEP", & + fldListfile ="TBOT:QBOT:WIND:PSRF", & + fldListModel="tbot:qbot:wind:psrf", & + filepath=& + "/fs/cgd/csm/inputdata/atm/datm7/atm_forcing.datm7.Qian.T62.c080727/TmpPrsHumWnd3Hrly", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & + domfilename="domain.T62.050609.nc", & + nfiles=12, filenames=clmncepTPQW(1:12) ) + yearAlign = 1 + yearFirst = 2003 + yearLast = 2003 +#ifndef LINUX + else if ( series == GISS_TEST )then + test_descrip = "GISS" + call streams_exp_set( stream_exp, datasource="GISS", & + fldListfile = "lwdn:swdn:swup", & + fldListModel= "lwdn:swdn:swup", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/TN460/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/TN460/", & + domXvarName="lon", & + domYvarName="lat", & + domfilename="tn460nyf.giss.T62.051007.nc", & + nfiles=1, filenames=(/ "tn460nyf.giss.T62.051007.nc" /) ) + else if ( series == CAMHIST_TEST )then + test_descrip = "CAMHIST" + yearAlign = 5 + yearFirst = 5 + yearLast = 6 + call streams_exp_set( stream_exp, datasource="CAMHIST", & + fldListfile = & + "FSNS:PRECC:PRECL:PRECSC:PRECSL:PS:PSL:QBOT:SOLL:SOLLD:SOLS:SOLSD:SRFRAD:FSNS:TBOT:UBOT:VBOT:ZBOT", & + fldListModel= & + "swnet:precc:precl:snowc:snowl:ps:pslv:shum:swndr:swndf:swvdr:swvdf:srfrad:swnet:tbot:u:v:z", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & + domfilename="domain.T42.050516.nc", & + nfiles=2, filenames=(/ & + "eul64x128_datm6.01.cam2.h1.0005-01-01-00000.nc", & + "eul64x128_datm6.01.cam2.h1.0006-01-01-00000.nc" & + /) ) +#endif + end if + write(*,*) "Write streams out to file" + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + write(*,*) "Initialize shr_streams" + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign ) + if ( series > 1 )then + write(*,*) "Get time bounds..." + secIn = 0 + write(*,*) "mDateIn, SecIn, mDateLB,mDateUB, dDateLB,dDateUB, secLB, secUB" + allocate( expected((yearLast-yearFirst+3)*12) ) + allocate( value((yearLast-yearFirst+3)*12) ) + n = 0 + do year = yearAlign-1, yearAlign+1+(yearLast-yearFirst) + do month = 1, 12 + n = n + 1 + mDateIn = year * 10000 + month*100 + 1 + call shr_stream_findBounds(streams(1),mDateIn, secIn, & + & mDateLB,dDateLB,secLB,n_lb,fileLB, & + & mDateUB,dDateUB,secUB,n_ub,fileUB ) + if ( year < yearFirst )then + expected(n) = yearLast * 10000 + month*100 + 1 + else if ( year > yearLast )then + expected(n) = yearFirst * 10000 + month*100 + 1 + else + expected(n) = year * 10000 + month*100 + 1 + end if + if ( series == CAMHIST_TEST ) expected(n) = expected(n) + 1 + value(n) = dDateUB + write(6,'(8i9)') mDateIn, SecIn, mDateLB,mDateUB, dDateLB,dDateUB, & + secLB, secUB + end do + end do + call test_is( value, expected, " test if expected values") + deallocate( expected ) + deallocate( value ) + end if + call shr_stream_dataDump( streams(1) ) + write(*,*) "Check if it is as expected..." + call test_is( is_streams_expected( streams(1), stream_exp ), & + "test if initialization is what expected "//trim(test_descrip) ) + write(*,*) "Write restart file out" + call shr_stream_restWrite( streams, rest_filename, caseName="clmrun", & + caseDesc="clmrun description" ) + write(*,*) "Read that file into a different stream" + call shr_stream_init( streams2(1), stream_filename, yearFirst, yearLast, yearAlign ) + call shr_stream_restRead( streams2, rest_filename ) + write(*,*) "Check if read restart is as expected..." + call test_is( is_streams_expected( streams2(1), stream_exp ), & + "test after read restart "//trim(test_descrip) ) + deallocate( streams ) + deallocate( streams2 ) + call shr_sys_system( "/bin/rm -f "//trim(stream_filename), rcode ) + call shr_sys_system( "/bin/rm -f "//trim(rest_filename), rcode ) + end do + + ! Fail tests + call shr_stream_setAbort( .false. ) + call shr_string_setAbort( .false. ) + allocate( streams(1) ) + allocate( streams2(1) ) + + write(*,*) "Try to write uninitialized stream out" + call shr_stream_restWrite( streams, rest_filename, caseName="clmrun", & + caseDesc="clmrun description", rc=rcode ) + call test_is( rcode, 1, "test that writing uninitialized stream fails" ) + + write(*,*) "Try to read uninitialized stream in" + call shr_stream_restRead( streams2, rest_filename, rc=rCode ) + call test_is( rcode, 1, "test that reading uninitialized stream fails" ) + + mDateIn = 20000101 + write(*,*) "Try to find bounds on uninitialized stream" + call shr_stream_findBounds(streams(1),mDateIn, secIn, & + & mDateLB,dDateLB,secLB,n_lb,fileLB, & + & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) + call test_is( rcode, 1, "test that find bounds of uninitialized stream fails" ) + + + do series = 1, 99 + yearAlign = 1 + yearFirst = 1 + yearLast = 1 + call streams_exp_init( stream_exp ) + if ( series == 1 )then + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign ) + test_descrip = "Try to read restart file that does not exist" + call shr_sys_system( "/bin/rm -f "//trim(rest_filename), rcode ) + call shr_stream_restRead( streams, rest_filename, rc=rCode ) + exp_int = 2 + else if ( series == 2 )then + test_descrip = "Try to initialize streams with too many files" + nfiles = 1001 + do i = 1, nfiles + write(filenames1(i),'("filename",i4.4,".nc")' ) i + end do + call streams_exp_set( stream_exp, datasource="CAMHIST", & + fldListfile = & + "FSNS:PRECC:PRECL:PRECSC:PRECSL:PS:PSL:QBOT:SOLL:SOLLD:SOLS:SOLSD:SRFRAD:FSNS:TBOT:UBOT:VBOT:ZBOT", & + fldListModel= & + "swnet:precc:precl:snowc:snowl:ps:pslv:shum:swndr:swndf:swvdr:swvdf:srfrad:swnet:tbot:u:v:z", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/CAMHIST/", & + domfilename="domain.T42.050516.nc", & + nfiles=nfiles, filenames=filenames1(1:nfiles) ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 3 )then + test_descrip = "variable name lists do not have same number of values" + call streams_exp_set( stream_exp, datasource="CLMNCEP", & + fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & + fldListModel="tbot:qbot:wind:prectMMS", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & + domfilename="domain.T62.050609.nc", & + nfiles=12, filenames=clmncep(1:12) ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 4 )then + test_descrip = "Mask name set to blank" + call streams_exp_set( stream_exp, domMaskName=" " ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 5 )then + test_descrip = "Area name set to blank" + call streams_exp_set( stream_exp, domAreaName=" " ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 6 )then + test_descrip = "Yvar name set to blank" + call streams_exp_set( stream_exp, domYVarName=" " ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 7 )then + test_descrip = "Xvar name set to blank" + call streams_exp_set( stream_exp, domXVarName=" " ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 8 )then + test_descrip = "tvar name set to blank" + call streams_exp_set( stream_exp, domTVarName=" " ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 9 )then + test_descrip = "no filenames" + call streams_exp_set( stream_exp, nfiles=0, filenames=(/" "/) ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 10 )then + test_descrip = "no fieldnames" + call streams_exp_set( stream_exp, fldListfile ="", fldListModel="" ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + exp_int = 1 + else if ( series == 11 )then + test_descrip = "Dates are out of range" + call streams_exp_set( stream_exp, datasource="CLMNCEP", & + fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & + fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & + domfilename="domain.T62.050609.nc", & + nfiles=12, filenames=clmncep(1:12) ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + yearAlign = 1948 + yearFirst = 1952 + yearLast = 1952 + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign ) + secIn = 0 + mDateIn = yearAlign * 10000 + 12*100 + 1 + call shr_stream_findBounds(streams(1),mDateIn, secIn, & + & mDateLB,dDateLB,secLB,n_lb,fileLB, & + & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) + exp_int = 1 + else if ( series == 12 )then + test_descrip = "One file is out of sequence" + filenames2 = clmncep + filenames2(2) = clmncep(4) + filenames2(4) = clmncep(2) + call streams_exp_set( stream_exp, datasource="CLMNCEP", & + fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & + fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & + filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & + domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & + domfilename="domain.T62.050609.nc", & + nfiles=12, filenames=filenames2 ) + call streams_exp_write_strm_txt( stream_filename, stream_exp ) + yearAlign = 1948 + yearFirst = 1948 + yearLast = 1948 + call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, & + yearAlign, rc=rCode ) + secIn = 0 + mDateIn = yearAlign * 10000 + 12*100 + 1 + call shr_stream_findBounds(streams(1),mDateIn, secIn, & + & mDateLB,dDateLB,secLB,n_lb,fileLB, & + & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) + exp_int = 1 +! else if ( series == 12 )then +! test_descrip = "year range is out of bounds" +! call streams_exp_set( stream_exp, datasource="CLMNCEP", & +! fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & +! fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & +! filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & +! domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & +! domfilename="domain.T62.050609.nc", & +! nfiles=12, filenames=clmncep(1:12) ) +! yearAlign = 1948 +! yearFirst = 1948 +! yearLast = 1972 +! call streams_exp_write_strm_txt( stream_filename, stream_exp ) +! call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign, rCode ) +! secIn = 0 +! mDateIn = yearAlign * 10000 + 12*100 + 1 +! call shr_stream_findBounds(streams(1),mDateIn, secIn, & +! & mDateLB,dDateLB,secLB,n_lb,fileLB, & +! & mDateUB,dDateUB,secUB,n_ub,fileUB ) +! exp_int = 1 +! else if ( series == 13 )then +! test_descrip = "Dates are backwards" +! call streams_exp_set( stream_exp, datasource="CLMNCEP", & +! fldListfile ="TBOT:QBOT:WIND:PRECTmms:FSDS:PSRF", & +! fldListModel="tbot:qbot:wind:prectMMS:fsds:psrf", & +! filepath="/fs/cgd/csm/inputdata/atm/datm7/CLMNCEP/", & +! domfilepath="/fs/cgd/csm/inputdata/atm/datm7/", & +! domfilename="domain.T62.050609.nc", & +! nfiles=12, filenames=clmncep(12:1:-1) ) +! call streams_exp_write_strm_txt( stream_filename, stream_exp ) +! yearAlign = 1948 +! yearFirst = 1948 +! yearLast = 1948 +! call shr_stream_init( streams(1), stream_filename, yearFirst, yearLast, yearAlign, rCode ) +! secIn = 0 +! mDateIn = yearAlign * 10000 + 12*100 + 1 +! call shr_stream_findBounds(streams(1),mDateIn, secIn, & +! & mDateLB,dDateLB,secLB,n_lb,fileLB, & +! & mDateUB,dDateUB,secUB,n_ub,fileUB, rc=rCode ) +! exp_int = 1 + else + exit + end if + write(*,*) trim(test_descrip) + call test_is( rcode, exp_int, "test that "//trim(test_descrip)//" fails" ) + end do + + call shr_sys_system( "/bin/rm -f "//trim(stream_filename), rcode ) + deallocate( streams ) + deallocate( streams2 ) + + call test_final() + +end program test_shr_streams + diff --git a/share/csm_share/test/old_unit_testers/test_shr_sys.F90 b/share/csm_share/test/old_unit_testers/test_shr_sys.F90 new file mode 100644 index 000000000000..bef77858f05b --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_sys.F90 @@ -0,0 +1,75 @@ + program test_shr_sys +! +! Simple unit-test program for the shr_sys_mod module. +! +! Erik Kluzek +! +! $Id: test_shr_sys.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ +! + use shr_kind_mod, only: SHR_KIND_I8, SHR_KIND_R8 + use shr_sys_mod, only: shr_sys_irtc, shr_sys_system, shr_sys_flush, & + shr_sys_getenv, shr_sys_chdir, shr_sys_sleep, & + shr_sys_abort + implicit none + real(SHR_KIND_R8) sum + integer i +#if (defined AIX) + integer(kind=8):: irtc0, irtcf + integer(kind=8):: irtc +#endif + integer(SHR_KIND_I8):: sirtc0, sirtcf, rate + integer rcode + character(len=90) val + real(SHR_KIND_R8) :: sec + + print *, "Unit-tester for shr_sys_mod" + print *, "First lets test the shr_sys_irtc function" +#if (defined AIX) + irtc0 = irtc( ) +#endif + sirtc0 = shr_sys_irtc( ) + sum = 0.0_SHR_KIND_R8 + do i = 1, 10000000 + sum = sum + exp( (i*5.0_SHR_KIND_R8*3.14159265_SHR_KIND_R8) / (i + 10.0_SHR_KIND_R8) ) + end do + sirtcf = shr_sys_irtc( ) +#if (defined AIX) + print *, 'irtc call: ', irtcf - irtc0 +#endif +#if (defined AIX) + irtcf = irtc( ) +#endif + print *, 'shr_sys_irtc call: ', sirtcf - sirtc0 + print *, 'Test the getenv call' + call shr_sys_getenv( "LOGNAME", val, rcode ) + print *, "value of LOGNAME = ", val + print *, 'Test the chdir call (just do a chdir .)' + call shr_sys_system( "pwd", rcode ) + call shr_sys_chdir( ".", rcode ) + call shr_sys_system( "pwd", rcode ) + sec = 55.0_SHR_KIND_R8 + print *, 'Test the shr_sys_sleep call for a ', sec, ' second sleep' +#if (defined AIX) + irtc0 = irtc( ) +#endif + sirtc0 = shr_sys_irtc( ) + call shr_sys_sleep( sec ) + sirtcf = shr_sys_irtc( rate ) +#if (defined AIX) + irtcf = irtc( ) +#endif +#if (defined AIX) + print *, 'irtc call: ', irtcf - irtc0 + print *, 'irtc call: ', irtcf, irtc0 +#endif + print *, 'shr_sys_irtc call: ', sirtcf - sirtc0, ' seconds: ', (sirtcf - sirtc0)/rate + print *, 'shr_sys_irtc call: ', sirtcf, sirtc0 + print *, 'Test the shr_sys_flush call' + call shr_sys_flush( 6 ) + print *, 'PASS' + print *, 'Next test should abort appropriatly -- if it does so -- tests PASS' + print *, 'Finally test the shr_sys_abort call' + call shr_sys_abort + print *, 'abort call does NOT abort code -- something is wrong' + print *, 'FAIL' + end program test_shr_sys diff --git a/share/csm_share/test/old_unit_testers/test_shr_tInterp.F90 b/share/csm_share/test/old_unit_testers/test_shr_tInterp.F90 new file mode 100644 index 000000000000..2a29f5b5f3d5 --- /dev/null +++ b/share/csm_share/test/old_unit_testers/test_shr_tInterp.F90 @@ -0,0 +1,108 @@ +program test_shr_tInterp +use shr_kind_mod +use test_mod +use shr_tInterp_mod +use shr_cal_mod, only : shr_cal_noleap +use shr_const_mod, only : SHR_CONST_CDAY + +implicit none + +integer :: date_lb, date_ub, date_in +integer :: sec_lb, sec_ub, sec_in +real(SHR_KIND_R8) :: f1, f2 +character(SHR_KIND_CS) :: alogo +character(SHR_KIND_CS) :: calendar_name = shr_cal_noleap +real(SHR_KIND_R8) :: expected(2), values(2) +integer :: rc +integer, parameter :: LIN_TEST = 1, LOWER_TEST = 2, UPPER_TEST = 3, & + NEAREST_TEST = 4, num_tests = 4, num_times = 47 +integer :: n, i + +call test_init( num_tests*num_times+3 ) +do n = 1, num_tests + if ( n == LIN_TEST )then + alogo = 'linear' + else if ( n == LOWER_TEST )then + alogo = 'lower' + else if ( n == UPPER_TEST )then + alogo = 'upper' + else if ( n == NEAREST_TEST )then + alogo = 'nearest' + end if + + write(*,*) "Test type: ", trim(alogo) + + date_lb = 20010101 + date_ub = 20010102 + sec_lb = 0 + sec_ub = 0 + date_in = 20010101 + sec_in = 0 + do i = 1, num_times + write(*,*) "seconds in ", sec_in + if ( n == LIN_TEST )then + f1 = sec_in / SHR_CONST_CDAY + expected = (/ 1.0_SHR_KIND_R8 - f1, f1 /) + else if ( n == LOWER_TEST )then + expected = (/ 1.0_SHR_KIND_R8, 0.0_SHR_KIND_R8 /) + else if ( n == UPPER_TEST )then + expected = (/ 0.0_SHR_KIND_R8, 1.0_SHR_KIND_R8 /) + else if ( n == NEAREST_TEST )then + if ( sec_in <= SHR_CONST_CDAY /2 )then + expected = (/ 1.0_SHR_KIND_R8, 0.0_SHR_KIND_R8 /) + else + expected = (/ 0.0_SHR_KIND_R8, 1.0_SHR_KIND_R8 /) + end if + end if + call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & + sec_in, f1, f2, calendar_name, algo=alogo ) + values(1) = f1 + values(2) = f2 + if ( alogo == "linear" )then + call test_close( values, expected, 1.e-10_SHR_KIND_R8, "Test if factors are as expected" ) + else + call test_is( values, expected, "Test if factors are as expected" ) + end if + sec_in = sec_in + 1800 + end do +end do + +! Error tests +call shr_tInterp_setAbort( flag=.false. ) + +alogo = 'linear' + +! lb and ub dates are the same +date_lb = 20010101 +date_ub = 20010101 +sec_lb = 1457 +sec_ub = 1456 +date_in = 20010101 +sec_in = 1456 +call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & + sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) +call test_is( rc, expected=1, description="Test that aborts if ub < lb date" ) + +! unrecognized alogorithm name + +alogo = 'zztop' +call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & + sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) +call test_is( rc, expected=1, description="Test that recognizes a bad alogo name" ) + +! Test that abort if input date is outside of interval of lb and ub + +alogo = 'linear' +date_lb = 20010101 +date_ub = 20010115 +sec_lb = 0 +sec_ub = 0 +date_in = 20010205 +sec_in = 1456 +call shr_tInterp_getFactors( date_lb, sec_lb, date_ub, sec_ub, date_in, & + sec_in, f1, f2, calendar_name, algo=alogo, rc=rc ) +call test_is( rc, expected=1, description="Test that aborts for linear if input date is outside range of lb and ub dates" ) + +call test_final( ) + +end program test_shr_tInterp diff --git a/share/csm_share/test/unit/CMakeLists.txt b/share/csm_share/test/unit/CMakeLists.txt new file mode 100644 index 000000000000..f4f75b91af9d --- /dev/null +++ b/share/csm_share/test/unit/CMakeLists.txt @@ -0,0 +1,21 @@ +add_subdirectory(mock) + +add_subdirectory(shr_assert_test) + +add_subdirectory(shr_spfn_test) + +add_subdirectory(shr_infnan_test) + +add_subdirectory(shr_string_test) + +add_subdirectory(shr_strconvert_test) + +add_subdirectory(shr_log_test) + +add_subdirectory(dynamic_vector) + +add_subdirectory(shr_vmath_test) + +add_subdirectory(shr_wv_sat_test) + +add_subdirectory(shr_precip_test) diff --git a/share/csm_share/test/unit/dynamic_vector/CMakeLists.txt b/share/csm_share/test/unit/dynamic_vector/CMakeLists.txt new file mode 100644 index 000000000000..1ea9105ad203 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/CMakeLists.txt @@ -0,0 +1,88 @@ +include_directories(.) + +# Because these tests use type parameterization, unfortunately we need to +# preprocess *before* running the pFUnit preprocessor, then again *after*. +if(${CMAKE_C_COMPILER_ID} STREQUAL GNU) + function(make_cpp_command varname start_file end_file) + set(${varname} ${CMAKE_C_COMPILER} -E -x c ${start_file} -o ${end_file} + PARENT_SCOPE) + endfunction() +elseif(${CMAKE_C_COMPILER_ID} STREQUAL Intel) + function(make_cpp_command varname start_file end_file) + set(${varname} ${CMAKE_C_COMPILER} -E ${start_file} -o ${end_file} + PARENT_SCOPE) + endfunction() +elseif(${CMAKE_C_COMPILER_ID} STREQUAL XL) + function(make_cpp_command varname start_file end_file) + get_filename_component(start_base ${start_file} NAME) + string(REGEX REPLACE "\\.[^.]+$" ".i" cpp_output ${start_base}) + # Unfortunately, the C preprocessor doesn't like Fortran syntax, and + # returns a non-zero error code even though it succeeds. Use "|| :" to + # tell CMake that the command succeeded. + set(${varname} ${CMAKE_C_COMPILER} -E ${start_file} > ${end_file} || : + PARENT_SCOPE) + endfunction() +endif() + +# Function to preprocess the input to the output with the C preprocessor. +# Any extra arguments are interpreted as header files that preprocessing +# depends on. Unfortunately, we lose CMake's intrinsic capability to +# track included files as dependencies. +function(c_preprocess in_file out_file) + if(IS_ABSOLUTE "${in_file}") + set(start_file "${in_file}") + else() + set(start_file "${CMAKE_CURRENT_SOURCE_DIR}/${in_file}") + endif() + if(IS_ABSOLUTE "${out_file}") + set(end_file "${out_file}") + else() + set(end_file "${CMAKE_CURRENT_BINARY_DIR}/${out_file}") + endif() + set(includes ${ARGN}) + + make_cpp_command(cpp_command ${start_file} ${end_file}) + + add_custom_command( + OUTPUT ${end_file} + COMMAND ${cpp_command} + DEPENDS ${start_file} ${includes} + ) + +endfunction() + +# Included in tests we preprocess here. +set(test_include + ${CMAKE_CURRENT_SOURCE_DIR}/dynamic_vector_base_tests.inc) + +# Clear before loop below. +unset(pf_sources) + +# File with int_ptr type. +set(test_sources ptr_wrapper.F90) + +set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 + shr_strconvert_mod.F90 shr_log_mod.F90) +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +# Loop over type tests. +# +# The idea is that integer tests an intrinsic type, real(r8) is a type with +# a kind, character is special because of its length and substring syntax, +# and int_ptr is a simple derived type. + +# "character16" could be in the following list, but right now it is broken +# on multiple compilers due to compiler bugs. +foreach(type IN ITEMS integer r8 int_ptr) +c_preprocess(${type}_vector_tests.pf.in ${type}_vector_tests.pf + ${test_include}) + list(APPEND pf_sources + ${CMAKE_CURRENT_BINARY_DIR}/${type}_vector_tests.pf) + list(APPEND test_sources + dynamic_vector_${type}.F90) +endforeach() + +create_pFUnit_test(dynamic_vector dynamic_vector_exe + "${pf_sources}" "${test_sources}") + +declare_generated_dependencies(dynamic_vector_exe "${share_genf90_sources}") diff --git a/share/csm_share/test/unit/dynamic_vector/character16_vector_tests.pf.in b/share/csm_share/test/unit/dynamic_vector/character16_vector_tests.pf.in new file mode 100644 index 000000000000..5b4183f81b4e --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/character16_vector_tests.pf.in @@ -0,0 +1,61 @@ +module character16_vector_tests +! Module to test dynamic vector template on +! character strings. + +use pfunit_mod + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +#define TYPE_NAME character16 +#define TYPE_DECL character(len=16) +#define VECTOR_NAME character16_vector +use dynamic_vector_character16, only: & + character16_vector + +implicit none + +character(len=16), parameter :: test_array(3) = [ & + "Alice ", & + "Bob ", & + "Charlie " ] + +character(len=16), parameter :: test_array_2(5) = [& + "David ", & + "Eve ", & + "Fred ", & + "Georgia ", & + "Hank " ] + +character(len=16), parameter :: new_val = "Irene " + +interface assertEqual + module procedure assertEqualString_0D_1D + module procedure assertEqualString_1D_1D +end interface + +contains + +! pFUnit doesn't have assertEqual routines for arrays of strings. +subroutine assertEqualString_0D_1D(expected, found, message, location) + character(len=*), intent(in) :: expected + character(len=*), intent(in) :: found(:) + character(len=*), optional, intent(in) :: message + type (SourceLocation), optional, intent(in) :: location + + call assertAll(expected == found, message, location) + +end subroutine assertEqualString_0D_1D + +subroutine assertEqualString_1D_1D(expected, found, message, location) + character(len=*), intent(in) :: expected(:) + character(len=*), intent(in) :: found(:) + character(len=*), optional, intent(in) :: message + type (SourceLocation), optional, intent(in) :: location + + call assertAll(expected == found, message, location) + +end subroutine assertEqualString_1D_1D + +#include "dynamic_vector_base_tests.inc" + +end module character16_vector_tests diff --git a/share/csm_share/test/unit/dynamic_vector/dynamic_vector_base_tests.inc b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_base_tests.inc new file mode 100644 index 000000000000..fd0b278532fe --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_base_tests.inc @@ -0,0 +1,1152 @@ +! Test template for dynamic vector template. +! +! Include in module after "contains" with these prerequisites: +! - Use the vector from the module where it is defined. +! - Use shr_log_OOBMsg from shr_log_mod. +! - Define TYPE_NAME as the name of the type held by the vector. +! - Define TYPE_DECL as a declaration of the type held by the vector (e.g. +! "real(r8)" or "type(foo)". +! - Define VECTOR_NAME as the name of the vector type. +! - Define test arrays global to the module: +! - One named "test_array" with 3 elements +! - One named "test_array_2" with 5 elements +! - Define a scalar value of the type held by the vector, +! named "new_val". +! + +! We want to prefix with the type name so that it's possible to tell which test +! failed when pFUnit reports the test routine's name. +! This concatenation likely requires a real cpp for concatenation, rather than +! an fpp that may not implement "##". +#define CONCAT_UNDERSCORE(x, y) x ## _ ## y +#define CONCAT_EXPAND_UNDERSCORE(x, y) CONCAT_UNDERSCORE(x, y) +#define ADD_PREFIX(name) CONCAT_EXPAND_UNDERSCORE(TYPE_NAME, name) + +@Test +subroutine ADD_PREFIX(empty)() + + type( VECTOR_NAME ) :: vec + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(empty) + +@Test +subroutine ADD_PREFIX(alloc_empty)() + + type( VECTOR_NAME ) :: vec + + call vec%reserve(5) + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(alloc_empty) + +@Test +subroutine ADD_PREFIX(non_empty)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + @assertFalse(vec%empty()) + +end subroutine ADD_PREFIX(non_empty) + +@Test +subroutine ADD_PREFIX(default_constructor)() + + type( VECTOR_NAME ) :: vec + + vec = VECTOR_NAME () + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(default_constructor) + +@Test +subroutine ADD_PREFIX(assign_empty_array)() + + type( VECTOR_NAME ) :: vec + TYPE_DECL :: new_array(0) + + vec = new_array + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(assign_empty_array) + +@Test +subroutine ADD_PREFIX(size)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + @assertEqual(size(test_array), vec%vsize()) + +end subroutine ADD_PREFIX(size) + +@Test +subroutine ADD_PREFIX(size_empty)() + + type( VECTOR_NAME ) :: vec + + @assertEqual(0, vec%vsize()) + +end subroutine ADD_PREFIX(size_empty) + +@Test +subroutine ADD_PREFIX(max_size)() + + type( VECTOR_NAME ) :: vec + + ! No idea how you could verify this. Just + ! make sure it's more than 0. + @assertLessThan(0, vec%max_size()) + +end subroutine ADD_PREFIX(max_size) + +@Test +subroutine ADD_PREFIX(capacity)() + + type( VECTOR_NAME ) :: vec + + call vec%reserve(5) + + @assertEqual(5, vec%capacity()) + +end subroutine ADD_PREFIX(capacity) + +@Test +subroutine ADD_PREFIX(empty_capacity)() + + type( VECTOR_NAME ) :: vec + + @assertEqual(0, vec%capacity()) + +end subroutine ADD_PREFIX(empty_capacity) + +@Test +subroutine ADD_PREFIX(get)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL :: compare_array(size(test_array)) + + integer :: i + + vec = test_array + + do i = 1, size(test_array) + compare_array(i) = vec%get(i) + end do + + @assertEqual(test_array, compare_array) + +end subroutine ADD_PREFIX(get) + +@Test +subroutine ADD_PREFIX(get_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL :: throw_away + + integer :: i + + vec = test_array + + throw_away = vec%get(0) + + call assertExceptionRaised(OOBMsg("get", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(get_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(get_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL :: throw_away + + integer :: i + + vec = test_array + + throw_away = vec%get(size(test_array)+1) + + call assertExceptionRaised(OOBMsg("get", [1, vec%vsize()], size(test_array)+1)) + +end subroutine ADD_PREFIX(get_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(get_range)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 2 + integer, parameter :: end = 4 + + vec = test_array_2 + + @assertEqual(test_array_2(begin:end), vec%get(begin, end)) + +end subroutine ADD_PREFIX(get_range) + +@Test +subroutine ADD_PREFIX(get_range_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: throw_away(:) + + vec = test_array + + throw_away = vec%get(0, size(test_array)) + + call assertExceptionRaised(OOBMsg("get", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(get_range_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(get_range_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: throw_away(:) + + vec = test_array + + throw_away = vec%get(1, size(test_array)+1) + + call assertExceptionRaised(OOBMsg("get", [1, vec%vsize()], size(test_array)+1)) + +end subroutine ADD_PREFIX(get_range_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(get_range_stride)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 1 + integer, parameter :: end = 5 + integer, parameter :: stride = 2 + + vec = test_array_2 + + @assertEqual(test_array_2(begin:end:stride), vec%get(begin, end, stride)) + +end subroutine ADD_PREFIX(get_range_stride) + +@Test +subroutine ADD_PREFIX(get_array)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + @assertEqual(test_array, vec%get()) + +end subroutine ADD_PREFIX(get_array) + +@Test +subroutine ADD_PREFIX(array_constructor)() + + type( VECTOR_NAME ) :: vec + + vec = VECTOR_NAME (test_array) + + @assertEqual(test_array, vec%get()) + +end subroutine ADD_PREFIX(array_constructor) + +@Test +subroutine ADD_PREFIX(copy_constructor)() + + type( VECTOR_NAME ) :: vec1 + type( VECTOR_NAME ) :: vec2 + + vec1 = test_array + vec2 = VECTOR_NAME (vec1) + + @assertEqual(test_array, vec2%get()) + +end subroutine ADD_PREFIX(copy_constructor) + +@Test +subroutine ADD_PREFIX(front)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + @assertEqual(test_array(1), vec%front()) + +end subroutine ADD_PREFIX(front) + +@Test +subroutine ADD_PREFIX(front_bnd_chk)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL :: throw_away + + throw_away = vec%front() + + call assertExceptionRaised(OOBMsg("get", [1, 0], 1)) + +end subroutine ADD_PREFIX(front_bnd_chk) + +@Test +subroutine ADD_PREFIX(back)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + @assertEqual(test_array(size(test_array)), vec%back()) + +end subroutine ADD_PREFIX(back) + +@Test +subroutine ADD_PREFIX(back_bnd_chk)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL :: throw_away + + throw_away = vec%back() + + call assertExceptionRaised(OOBMsg("get", [1, 0], 0)) + +end subroutine ADD_PREFIX(back_bnd_chk) + +@Test +subroutine ADD_PREFIX(clear)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%clear() + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(clear) + +@Test +subroutine ADD_PREFIX(resize)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: new_size = 5 + + vec = test_array + + call vec%resize(new_size) + + @assertEqual(new_size, vec%vsize()) + @assertLessThanOrEqual(new_size, vec%capacity()) + +end subroutine ADD_PREFIX(resize) + +@Test +subroutine ADD_PREFIX(resize_fill)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: new_size = 5 + + vec = test_array + + call vec%resize(new_size, new_val) + + @assertEqual(new_size, vec%vsize()) + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(new_val, vec%get(size(test_array)+1, vec%vsize())) + +end subroutine ADD_PREFIX(resize_fill) + +@Test +subroutine ADD_PREFIX(resize_negative)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: new_size = -1 + + vec = test_array + + call vec%resize(new_size) + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(resize_negative) + +@Test +subroutine ADD_PREFIX(set)() + + type( VECTOR_NAME ) :: vec + + integer :: i + + vec = test_array_2 + + do i = 1, size(test_array) + call vec%set(test_array(i), i) + end do + + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(test_array_2(size(test_array)+1:), vec%get(size(test_array)+1, vec%vsize())) + +end subroutine ADD_PREFIX(set) + +@Test +subroutine ADD_PREFIX(set_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(new_val, 0) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(set_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(set_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(new_val, size(test_array)+1) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], size(test_array)+1)) + +end subroutine ADD_PREFIX(set_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(set_range)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 2 + integer, parameter :: end = 4 + + TYPE_DECL :: compare_array(size(test_array_2)) + + vec = test_array_2 + + call vec%set(test_array, begin, end) + + compare_array = test_array_2 + compare_array(begin:end) = test_array + + @assertEqual(compare_array, vec%get()) + +end subroutine ADD_PREFIX(set_range) + +@Test +subroutine ADD_PREFIX(set_range_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array_2 + + call vec%set(test_array, 0, size(test_array)-1) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(set_range_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(set_range_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array_2 + + call vec%set(test_array, & + size(test_array_2)-size(test_array)+1, size(test_array_2)+1) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], size(test_array_2)+1)) + +end subroutine ADD_PREFIX(set_range_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(set_range_stride)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 1 + integer, parameter :: end = 5 + integer, parameter :: stride = 2 + + TYPE_DECL :: compare_array(size(test_array_2)) + + vec = test_array_2 + + call vec%set(test_array, begin, end, stride) + + compare_array = test_array_2 + compare_array(begin:end:stride) = test_array + + @assertEqual(compare_array, vec%get()) + +end subroutine ADD_PREFIX(set_range_stride) + +@Test +subroutine ADD_PREFIX(set_range_fill)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 2 + integer, parameter :: end = 4 + + TYPE_DECL :: compare_array(size(test_array_2)) + + vec = test_array_2 + + call vec%set(new_val, begin, end) + + compare_array = test_array_2 + compare_array(begin:end) = new_val + + @assertEqual(compare_array, vec%get()) + +end subroutine ADD_PREFIX(set_range_fill) + +@Test +subroutine ADD_PREFIX(set_range_fill_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(new_val, 0, 1) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(set_range_fill_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(set_range_fill_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(new_val, 1, size(test_array)+1) + + call assertExceptionRaised(OOBMsg("set", [1, vec%vsize()], size(test_array)+1)) + +end subroutine ADD_PREFIX(set_range_fill_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(set_range_stride_fill)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 1 + integer, parameter :: end = 5 + integer, parameter :: stride = 2 + + TYPE_DECL :: compare_array(size(test_array_2)) + + vec = test_array_2 + + call vec%set(new_val, begin, end, stride) + + compare_array = test_array_2 + compare_array(begin:end:stride) = new_val + + @assertEqual(compare_array, vec%get()) + +end subroutine ADD_PREFIX(set_range_stride_fill) + +@Test +subroutine ADD_PREFIX(set_array)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + ! Note: This does NOT resize the vector. + call vec%set(test_array_2(:size(test_array))) + + @assertEqual(test_array_2(:size(test_array)), vec%get()) + +end subroutine ADD_PREFIX(set_array) + +@Test +subroutine ADD_PREFIX(set_array_chk)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(test_array_2) + + call assertExceptionRaised("Input array is not the same size as the vector it sets.") + +end subroutine ADD_PREFIX(set_array_chk) + +@Test +subroutine ADD_PREFIX(set_fill)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%set(new_val) + + @assertEqual(new_val, vec%get()) + +end subroutine ADD_PREFIX(set_fill) + +@Test +subroutine ADD_PREFIX(push_back)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%push_back(new_val) + + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(new_val, vec%get(size(test_array)+1)) + +end subroutine ADD_PREFIX(push_back) + +@Test +subroutine ADD_PREFIX(pop_back)() + + type( VECTOR_NAME ) :: vec + + vec = test_array_2 + + call vec%pop_back() + + @assertEqual(test_array_2(:(size(test_array_2)-1)), vec%get()) + +end subroutine ADD_PREFIX(pop_back) + +@Test +subroutine ADD_PREFIX(pop_back_throw)() + + type( VECTOR_NAME ) :: vec + + call vec%pop_back() + + call assertExceptionRaised("Attempted to pop an element from an empty vector.") + +end subroutine ADD_PREFIX(pop_back_throw) + +@Test +subroutine ADD_PREFIX(insert)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: ins = 2 + + vec = test_array + + call vec%insert(ins, new_val) + + @assertEqual(test_array(:ins-1), vec%get(1, ins-1)) + @assertEqual(new_val, vec%get(ins)) + @assertEqual(test_array(ins:), vec%get(ins+1, size(test_array)+1)) + +end subroutine ADD_PREFIX(insert) + +@Test +subroutine ADD_PREFIX(insert_at_end)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(size(test_array)+1, new_val) + + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(new_val, vec%get(size(test_array)+1)) + +end subroutine ADD_PREFIX(insert_at_end) + +@Test +subroutine ADD_PREFIX(insert_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(0, new_val) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(insert_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(insert_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(size(test_array)+2, new_val) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], size(test_array)+2)) + +end subroutine ADD_PREFIX(insert_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(insert_array)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: ins = 2 + + vec = test_array + + call vec%insert(ins, test_array_2) + + @assertEqual(test_array(:ins-1), vec%get(1, ins-1)) + @assertEqual(test_array_2, vec%get(ins, ins-1+size(test_array_2))) + @assertEqual(test_array(ins:), vec%get(ins+size(test_array_2), size(test_array)+size(test_array_2))) + +end subroutine ADD_PREFIX(insert_array) + +@Test +subroutine ADD_PREFIX(insert_array_at_end)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(size(test_array)+1, test_array_2) + + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(test_array_2, vec%get(size(test_array)+1, size(test_array)+size(test_array_2))) + +end subroutine ADD_PREFIX(insert_array_at_end) + +@Test +subroutine ADD_PREFIX(insert_array_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(0, test_array_2) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(insert_array_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(insert_array_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(size(test_array)+2, test_array_2) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], size(test_array)+2)) + +end subroutine ADD_PREFIX(insert_array_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(insert_repeat)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: ins = 2 + + integer, parameter :: repeat_num = 3 + + vec = test_array + + call vec%insert(ins, new_val, repeat_num) + + @assertEqual(test_array(:ins-1), vec%get(1, ins-1)) + @assertEqual(new_val, vec%get(ins, ins-1+repeat_num)) + @assertEqual(test_array(ins:), vec%get(ins+repeat_num, size(test_array)+repeat_num)) + +end subroutine ADD_PREFIX(insert_repeat) + +@Test +subroutine ADD_PREFIX(insert_repeat_at_end)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: repeat_num = 3 + + vec = test_array + + call vec%insert(size(test_array)+1, new_val, repeat_num) + + @assertEqual(test_array, vec%get(1, size(test_array))) + @assertEqual(new_val, vec%get(size(test_array)+1, size(test_array)+repeat_num)) + +end subroutine ADD_PREFIX(insert_repeat_at_end) + +@Test +subroutine ADD_PREFIX(insert_repeat_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(0, new_val, 5) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(insert_repeat_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(insert_repeat_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%insert(size(test_array)+2, new_val, 5) + + call assertExceptionRaised(OOBMsg("insert", [1, vec%vsize()], size(test_array)+2)) + +end subroutine ADD_PREFIX(insert_repeat_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(erase)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: pos = 2 + + vec = test_array + + call vec%erase(pos) + + @assertEqual(test_array(:pos-1), vec%get(1, pos-1)) + @assertEqual(test_array(pos+1:), vec%get(pos, size(test_array)-1)) + +end subroutine ADD_PREFIX(erase) + +@Test +subroutine ADD_PREFIX(erase_at_end)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%erase(size(test_array)) + + @assertEqual(test_array(:size(test_array)-1), vec%get()) + +end subroutine ADD_PREFIX(erase_at_end) + +@Test +subroutine ADD_PREFIX(erase_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%erase(0) + + call assertExceptionRaised(OOBMsg("erase", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(erase_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(erase_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%erase(size(test_array)+1) + + call assertExceptionRaised(OOBMsg("erase", [1, vec%vsize()], size(test_array)+1)) + +end subroutine ADD_PREFIX(erase_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(erase_range)() + + type( VECTOR_NAME ) :: vec + + integer, parameter :: begin = 2 + integer, parameter :: end = 3 + + vec = test_array_2 + + call vec%erase(begin, end) + + @assertEqual(test_array_2(:begin-1), vec%get(1, begin-1)) + @assertEqual(test_array_2(end+1:), vec%get(begin, size(test_array_2)-end+begin-1)) + +end subroutine ADD_PREFIX(erase_range) + + +@Test +subroutine ADD_PREFIX(erase_range_at_end)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%erase(size(test_array)-1, size(test_array)) + + @assertEqual(test_array(:size(test_array)-2), vec%get()) + +end subroutine ADD_PREFIX(erase_range_at_end) +@Test +subroutine ADD_PREFIX(erase_range_bnd_chk_low)() + + type( VECTOR_NAME ) :: vec + + vec = test_array_2 + + call vec%erase(0, 1) + + call assertExceptionRaised(OOBMsg("erase", [1, vec%vsize()], 0)) + +end subroutine ADD_PREFIX(erase_range_bnd_chk_low) + +@Test +subroutine ADD_PREFIX(erase_range_bnd_chk_high)() + + type( VECTOR_NAME ) :: vec + + vec = test_array_2 + + call vec%erase(1, size(test_array_2)+1) + + call assertExceptionRaised(OOBMsg("erase", [1, vec%vsize()], size(test_array_2)+1)) + +end subroutine ADD_PREFIX(erase_range_bnd_chk_high) + +@Test +subroutine ADD_PREFIX(shrink_capacity_empty)() + + type( VECTOR_NAME ) :: vec + + call vec%shrink_to_fit() + + @assertEqual(0, vec%capacity()) + +end subroutine ADD_PREFIX(shrink_capacity_empty) + +@Test +subroutine ADD_PREFIX(shrink_capacity_alloc)() + + type( VECTOR_NAME ) :: vec + + call vec%reserve(5) + + call vec%shrink_to_fit() + + @assertEqual(0, vec%capacity()) + +end subroutine ADD_PREFIX(shrink_capacity_alloc) + +@Test +subroutine ADD_PREFIX(shrink_capacity_full)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%shrink_to_fit() + + @assertEqual(size(test_array), vec%capacity()) + +end subroutine ADD_PREFIX(shrink_capacity_full) + +@Test +subroutine ADD_PREFIX(reserve)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%reserve(size(test_array) + 1) + + @assertLessThanOrEqual(size(test_array) + 1, vec%capacity()) + +end subroutine ADD_PREFIX(reserve) + +@Test +subroutine ADD_PREFIX(reserve_noop)() + + type( VECTOR_NAME ) :: vec + + call vec%reserve(5) + + call vec%reserve(3) + + @assertLessThanOrEqual(5, vec%capacity()) + +end subroutine ADD_PREFIX(reserve_noop) + +@Test +subroutine ADD_PREFIX(shrink_capacity_fit)() + + type( VECTOR_NAME ) :: vec + + vec = test_array + + call vec%reserve(5) + + call vec%shrink_to_fit() + + @assertEqual(size(test_array), vec%capacity()) + +end subroutine ADD_PREFIX(shrink_capacity_fit) + +@Test +subroutine ADD_PREFIX(move_in)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: new_array(:) + + new_array = test_array + + call vec%move_in(new_array) + + @assertEqual(test_array, vec%get()) + +end subroutine ADD_PREFIX(move_in) + +@Test +subroutine ADD_PREFIX(move_in_empty)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: new_array(:) + + call vec%move_in(new_array) + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(move_in_empty) + +@Test +subroutine ADD_PREFIX(move_in_overwrite_with_empty)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: new_array(:) + + vec = test_array + + call vec%move_in(new_array) + + @assertTrue(vec%empty()) + +end subroutine ADD_PREFIX(move_in_overwrite_with_empty) + +@Test +subroutine ADD_PREFIX(move_out)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: new_array(:) + + vec = test_array + + call vec%move_out(new_array) + + @assertEqual(test_array, new_array) + +end subroutine ADD_PREFIX(move_out) + +@Test +subroutine ADD_PREFIX(move_out_empty)() + + type( VECTOR_NAME ) :: vec + + TYPE_DECL, allocatable :: new_array(:) + + call vec%move_out(new_array) + + @assertFalse(allocated(new_array)) + +end subroutine ADD_PREFIX(move_out_empty) + +@Test +subroutine ADD_PREFIX(swap)() + + type( VECTOR_NAME ) :: vec1 + type( VECTOR_NAME ) :: vec2 + + vec1 = test_array + vec2 = test_array_2 + + call vec1%swap(vec2) + + @assertEqual(test_array_2, vec1%get()) + @assertEqual(test_array, vec2%get()) + +end subroutine ADD_PREFIX(swap) + +@Test +subroutine ADD_PREFIX(swap_1st_empty)() + + type( VECTOR_NAME ) :: vec1 + type( VECTOR_NAME ) :: vec2 + + vec2 = test_array_2 + + call vec1%swap(vec2) + + @assertEqual(test_array_2, vec1%get()) + @assertTrue(vec2%empty()) + +end subroutine ADD_PREFIX(swap_1st_empty) + +@Test +subroutine ADD_PREFIX(swap_2nd_empty)() + + type( VECTOR_NAME ) :: vec1 + type( VECTOR_NAME ) :: vec2 + + vec1 = test_array + + call vec1%swap(vec2) + + @assertTrue(vec1%empty()) + @assertEqual(test_array, vec2%get()) + +end subroutine ADD_PREFIX(swap_2nd_empty) + +@Test +subroutine ADD_PREFIX(swap_both_empty)() + + type( VECTOR_NAME ) :: vec1 + type( VECTOR_NAME ) :: vec2 + + call vec1%swap(vec2) + + @assertTrue(vec1%empty()) + @assertTrue(vec2%empty()) + +end subroutine ADD_PREFIX(swap_both_empty) + +@Test +subroutine ADD_PREFIX(swap_with_self)() + + type( VECTOR_NAME ) :: vec1 + + vec1 = test_array + + call vec1%swap(vec1) + + @assertEqual(test_array, vec1%get()) + +end subroutine ADD_PREFIX(swap_with_self) diff --git a/share/csm_share/test/unit/dynamic_vector/dynamic_vector_character16.F90 b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_character16.F90 new file mode 100644 index 000000000000..77c28d94e411 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_character16.F90 @@ -0,0 +1,22 @@ +module dynamic_vector_character16 + +use pfunit_mod, only: throw + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +implicit none +private + +#define VECTOR_NAME character16_vector +#define TYPE_NAME character(len=16) +#define THROW(string) call throw(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +contains + +#include "dynamic_vector_procdef.inc" + +end module dynamic_vector_character16 diff --git a/share/csm_share/test/unit/dynamic_vector/dynamic_vector_int_ptr.F90 b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_int_ptr.F90 new file mode 100644 index 000000000000..0661526c5d11 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_int_ptr.F90 @@ -0,0 +1,24 @@ +module dynamic_vector_int_ptr + +use ptr_wrapper, only: int_ptr + +use pfunit_mod, only: throw + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +implicit none +private + +#define VECTOR_NAME int_ptr_vector +#define TYPE_NAME type(int_ptr) +#define THROW(string) call throw(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +contains + +#include "dynamic_vector_procdef.inc" + +end module dynamic_vector_int_ptr diff --git a/share/csm_share/test/unit/dynamic_vector/dynamic_vector_integer.F90 b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_integer.F90 new file mode 100644 index 000000000000..acb8887e2bc0 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_integer.F90 @@ -0,0 +1,22 @@ +module dynamic_vector_integer + +use pfunit_mod, only: throw + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +implicit none +private + +#define VECTOR_NAME integer_vector +#define TYPE_NAME integer +#define THROW(string) call throw(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +contains + +#include "dynamic_vector_procdef.inc" + +end module dynamic_vector_integer diff --git a/share/csm_share/test/unit/dynamic_vector/dynamic_vector_r8.F90 b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_r8.F90 new file mode 100644 index 000000000000..46574df06845 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/dynamic_vector_r8.F90 @@ -0,0 +1,25 @@ +module dynamic_vector_r8 + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_infnan_mod, only: assignment(=), nan => shr_infnan_nan + +use pfunit_mod, only: throw + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +implicit none +private + +#define VECTOR_NAME r8_vector +#define TYPE_NAME real(r8) +#define THROW(string) call throw(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +contains + +#include "dynamic_vector_procdef.inc" + +end module dynamic_vector_r8 diff --git a/share/csm_share/test/unit/dynamic_vector/int_ptr_vector_tests.pf.in b/share/csm_share/test/unit/dynamic_vector/int_ptr_vector_tests.pf.in new file mode 100644 index 000000000000..fd718c1dc1c7 --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/int_ptr_vector_tests.pf.in @@ -0,0 +1,105 @@ +module int_ptr_vector_tests +! Module to test dynamic vector template on +! a derived type. + +use pfunit_mod + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +use ptr_wrapper, only: & + int_ptr + +use dynamic_vector_int_ptr, only: & + int_ptr_vector + +#define TYPE_NAME int_ptr +#define TYPE_DECL type(TYPE_NAME) +#define VECTOR_NAME int_ptr_vector + +implicit none + +integer, target, save :: i1, i2, i3, i4, i5 + +type(int_ptr), save :: test_array(3) + +type(int_ptr), save :: test_array_2(5) + +type(int_ptr), save :: new_val + +interface assertEqual + module procedure assertEqual_int_ptr_0D_0D + module procedure assertEqual_int_ptr_0D_1D + module procedure assertEqual_int_ptr_1D_1D +end interface + +contains + +! This is necessary because pFUnit only knows about integers, not the +! pointer type that we've defined. +subroutine assertEqual_int_ptr_0D_0D(expected, found, message, location) + type(int_ptr), intent(in) :: expected + type(int_ptr), intent(in) :: found + character(len=*), optional, intent(in) :: message + type (SourceLocation), optional, intent(in) :: location + + call assertTrue(expected == found, message, location) + +end subroutine assertEqual_int_ptr_0D_0D + +subroutine assertEqual_int_ptr_0D_1D(expected, found, message, location) + type(int_ptr), intent(in) :: expected + type(int_ptr), intent(in) :: found(:) + character(len=*), optional, intent(in) :: message + type (SourceLocation), optional, intent(in) :: location + + call assertAll(expected == found, message, location) + +end subroutine assertEqual_int_ptr_0D_1D + +subroutine assertEqual_int_ptr_1D_1D(expected, found, message, location) + type(int_ptr), intent(in) :: expected(:) + type(int_ptr), intent(in) :: found(:) + character(len=*), optional, intent(in) :: message + type (SourceLocation), optional, intent(in) :: location + + call assertAll(expected == found, message, location) + +end subroutine assertEqual_int_ptr_1D_1D + +@Before +subroutine setUp() + + test_array(1)%p => i1 + test_array(2)%p => i2 + test_array(3)%p => i3 + + test_array_2(1)%p => i5 + test_array_2(2)%p => i4 + nullify(test_array_2(3)%p) + test_array_2(4)%p => i2 + test_array_2(5)%p => i1 + + new_val%p => i4 + +end subroutine setUp + +@After +subroutine tearDown() + + integer :: i + + do i = 1, size(test_array) + nullify(test_array(i)%p) + end do + + do i = 1, size(test_array_2) + nullify(test_array_2(i)%p) + end do + + nullify(new_val%p) + +end subroutine tearDown + +#include "dynamic_vector_base_tests.inc" + +end module int_ptr_vector_tests diff --git a/share/csm_share/test/unit/dynamic_vector/integer_vector_tests.pf.in b/share/csm_share/test/unit/dynamic_vector/integer_vector_tests.pf.in new file mode 100644 index 000000000000..4888891ec3bd --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/integer_vector_tests.pf.in @@ -0,0 +1,28 @@ +module integer_vector_tests +! Module to test dynamic vector template on +! integers. + +use pfunit_mod + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +#define TYPE_NAME integer +#define TYPE_DECL integer +#define VECTOR_NAME integer_vector + +use dynamic_vector_integer, only: & + integer_vector + +implicit none + +integer, parameter :: test_array(3) = [ 3, 2, 1 ] + +integer, parameter :: test_array_2(5) = [ 4, 5, 6, 7, 8 ] + +integer, parameter :: new_val = -1 + +contains + +#include "dynamic_vector_base_tests.inc" + +end module integer_vector_tests diff --git a/share/csm_share/test/unit/dynamic_vector/ptr_wrapper.F90 b/share/csm_share/test/unit/dynamic_vector/ptr_wrapper.F90 new file mode 100644 index 000000000000..920e6866bafa --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/ptr_wrapper.F90 @@ -0,0 +1,31 @@ +module ptr_wrapper + +! This module simply defines a wrapper for integer pointers in order to +! test the dynamic_vector type on a derived type. + +implicit none +private +save + +public :: int_ptr + +type int_ptr + integer, pointer :: p => null() + contains + procedure, pass(first) :: cmp => int_ptr_cmp + generic :: operator(==) => cmp +end type int_ptr + +contains + +elemental function int_ptr_cmp(first, second) result(is_same) + class(int_ptr), intent(in) :: first + class(int_ptr), intent(in) :: second + logical :: is_same + + is_same = associated(first%p, second%p) .or. & + (.not. associated(first%p) .and. .not. associated(second%p)) + +end function int_ptr_cmp + +end module ptr_wrapper diff --git a/share/csm_share/test/unit/dynamic_vector/r8_vector_tests.pf.in b/share/csm_share/test/unit/dynamic_vector/r8_vector_tests.pf.in new file mode 100644 index 000000000000..46f3362eda3e --- /dev/null +++ b/share/csm_share/test/unit/dynamic_vector/r8_vector_tests.pf.in @@ -0,0 +1,30 @@ +module r8_vector_tests +! Module to test dynamic vector template on reals. + +use pfunit_mod + +use shr_log_mod, only: OOBMsg => shr_log_OOBMsg + +use shr_kind_mod, only: r8 => shr_kind_r8 + +#define TYPE_NAME r8 +#define TYPE_DECL real(r8) +#define VECTOR_NAME r8_vector + +use dynamic_vector_r8, only: & + r8_vector + +implicit none + +real(r8), parameter :: test_array(3) = [ 1.2_r8, 2.3_r8, 6.4_r8 ] + +real(r8), parameter :: test_array_2(5) = & + [ 6.2_r8, 6.7_r8, 3.4_r8, 7.8_r8, 3.4_r8 ] + +real(r8), parameter :: new_val = -1.8_r8 + +contains + +#include "dynamic_vector_base_tests.inc" + +end module r8_vector_tests diff --git a/share/csm_share/test/unit/mock/CMakeLists.txt b/share/csm_share/test/unit/mock/CMakeLists.txt new file mode 100644 index 000000000000..e093c6878b82 --- /dev/null +++ b/share/csm_share/test/unit/mock/CMakeLists.txt @@ -0,0 +1,4 @@ +list(APPEND share_sources + shr_sys_mod.nompi_abortthrows.F90) + +sourcelist_to_parent(share_sources) diff --git a/share/csm_share/test/unit/mock/shr_sys_mod.nompi_abortthrows.F90 b/share/csm_share/test/unit/mock/shr_sys_mod.nompi_abortthrows.F90 new file mode 100644 index 000000000000..56b5c5a1ef3f --- /dev/null +++ b/share/csm_share/test/unit/mock/shr_sys_mod.nompi_abortthrows.F90 @@ -0,0 +1,53 @@ +module shr_sys_mod + +! This is a mock version of shr_sys_mod. +! It contains only a few routines that are needed, and an abort method that throws a pFUnit +! exception instead of actually aborting. + +use shr_kind_mod, only: & + shr_kind_in, shr_kind_r8 + +implicit none +private +save + +! Fake abort +public :: shr_sys_abort + +! Fake sleep +public :: shr_sys_sleep + +! Real flush +public :: shr_sys_flush + +contains + +subroutine shr_sys_abort(string, rc) + use pfunit_mod, only: throw + + character(*), optional :: string + integer(shr_kind_in), optional :: rc + + ! Prevent compiler spam about unused variables. + if (.false.) rc = rc + + call throw("ABORTED: "//trim(string)) + +end subroutine shr_sys_abort + +subroutine shr_sys_sleep(sec) + real(shr_kind_r8), intent(in) :: sec + + ! do nothing +end subroutine shr_sys_sleep + +SUBROUTINE shr_sys_flush(unit) + + !----- arguments ----- + integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit + + flush(unit) + +END SUBROUTINE shr_sys_flush + +end module shr_sys_mod diff --git a/share/csm_share/test/unit/shr_assert_test/CMakeLists.txt b/share/csm_share/test/unit/shr_assert_test/CMakeLists.txt new file mode 100644 index 000000000000..f3db802e47de --- /dev/null +++ b/share/csm_share/test/unit/shr_assert_test/CMakeLists.txt @@ -0,0 +1,13 @@ +set(pf_sources test_assert.pf test_assert_array.pf test_macro.pf + test_ndebug.pf) + +set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 + shr_strconvert_mod.F90 shr_log_mod.F90 + shr_sys_mod.nompi_abortthrows.F90 shr_assert_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +create_pFUnit_test(assert assert_test_exe "${pf_sources}" "${test_sources}") + +declare_generated_dependencies(assert_test_exe "${share_genf90_sources}") + diff --git a/share/csm_share/test/unit/shr_assert_test/test_assert.pf b/share/csm_share/test/unit/shr_assert_test/test_assert.pf new file mode 100644 index 000000000000..5bc7239e26fc --- /dev/null +++ b/share/csm_share/test/unit/shr_assert_test/test_assert.pf @@ -0,0 +1,50 @@ +module test_assert + +! Test basic assert functionality. + +use pfunit_mod + +use shr_assert_mod, only: & + shr_assert, & + shr_assert_all, & + shr_assert_any + +implicit none +save + +contains + +@Test +subroutine assert_can_pass() + call shr_assert(.true., "Assert unexpectedly aborted!") +end subroutine assert_can_pass + +@Test +subroutine assert_can_fail() + call shr_assert(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_can_fail + +@Test +subroutine assert_all_scalar_can_pass() + call shr_assert_all(.true., "Assert unexpectedly aborted!") +end subroutine assert_all_scalar_can_pass + +@Test +subroutine assert_all_scalar_can_fail() + call shr_assert_all(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_all_scalar_can_fail + +@Test +subroutine assert_any_scalar_can_pass() + call shr_assert_any(.true., "Assert unexpectedly aborted!") +end subroutine assert_any_scalar_can_pass + +@Test +subroutine assert_any_scalar_can_fail() + call shr_assert_any(.false., "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_any_scalar_can_fail + +end module test_assert diff --git a/share/csm_share/test/unit/shr_assert_test/test_assert_array.pf b/share/csm_share/test/unit/shr_assert_test/test_assert_array.pf new file mode 100644 index 000000000000..fba6137722fa --- /dev/null +++ b/share/csm_share/test/unit/shr_assert_test/test_assert_array.pf @@ -0,0 +1,185 @@ +module test_assert_array + +! Test shr_assert_all and shr_assert_any. + +use pfunit_mod + +use shr_assert_mod, only: & + shr_assert_all, & + shr_assert_any + +implicit none +save + +@TestParameter +type, extends(AbstractTestParameter) :: ArrayRank + integer :: rank + contains + procedure :: toString +end type ArrayRank + +@TestCase(testParameters={getParameters()}, constructor=new_TestAssertArray) +type, extends(ParameterizedTestCase) :: TestAssertArray + integer :: rank +end type TestAssertArray + +contains + +function new_TestAssertArray(rank) result(test) + type(ArrayRank), intent(in) :: rank + type(TestAssertArray) :: test + + test%rank = rank%rank + +end function new_TestAssertArray + +function getParameters() result(params) + type(ArrayRank), allocatable :: params(:) + + integer :: i + + params = [( ArrayRank(i), i = 1, 7 )] + +end function getParameters + +function toString(this) result(string) + class(ArrayRank), intent(in) :: this + character(:), allocatable :: string + + character(len=30) :: buffer + + write(buffer, '(A,I1,A)') "(rank = ",this%rank,")" + + string = trim(buffer) + +end function toString + +@Test +subroutine assert_all_size_zero_passes(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([logical::], 0, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_all_size_zero_passes + +@Test +subroutine assert_all_can_pass(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([.true.], 1, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_all_can_pass + +@Test +subroutine assert_all_can_fail(this) + class(TestAssertArray), intent(inout) :: this + call assert_all_wrapper([.false.], 1, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_all_can_fail + +@Test +subroutine assert_all_partial_false_fails(this) + class(TestAssertArray), intent(inout) :: this + logical :: test_array(2**this%rank) + integer :: i + test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] + call assert_all_wrapper(test_array, 2, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_all_partial_false_fails + +@Test +subroutine assert_any_size_zero_fails(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([logical::], 0, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_any_size_zero_fails + +@Test +subroutine assert_any_can_pass(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([.true.], 1, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_any_can_pass + +@Test +subroutine assert_any_can_fail(this) + class(TestAssertArray), intent(inout) :: this + call assert_any_wrapper([.false.], 1, this%rank, & + "Expected failure.") + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine assert_any_can_fail + +@Test +subroutine assert_any_partial_false_passes(this) + class(TestAssertArray), intent(inout) :: this + logical :: test_array(2**this%rank) + integer :: i + test_array = [( mod(i,2) == 0, i = 1, size(test_array) )] + call assert_any_wrapper(test_array, 2, this%rank, & + "Assert unexpectedly aborted!") +end subroutine assert_any_partial_false_passes + +! The wrappers are to allow rank-generic programming. +! The routines assert with the given array and message, but the array is +! resized to have "rank" dimensions of size "dimsize". + +subroutine assert_all_wrapper(array, dimsize, rank, msg) + logical, intent(in) :: array(:) + integer, intent(in) :: dimsize + integer, intent(in) :: rank + character(len=*), intent(in) :: msg + + integer :: i + + select case (rank) + case(1) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 1)]), msg) + case(2) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 2)]), msg) + case(3) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 3)]), msg) + case(4) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 4)]), msg) + case(5) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 5)]), msg) + case(6) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 6)]), msg) + case(7) + call shr_assert_all(reshape(array, [(dimsize, i = 1, 7)]), msg) + case default + call throw("assert_all_wrapper was given a bad rank.") + end select + +end subroutine assert_all_wrapper + +subroutine assert_any_wrapper(array, dimsize, rank, msg) + logical, intent(in) :: array(:) + integer, intent(in) :: dimsize + integer, intent(in) :: rank + character(len=*), intent(in) :: msg + + integer :: i + + select case (rank) + case(1) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 1)]), msg) + case(2) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 2)]), msg) + case(3) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 3)]), msg) + case(4) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 4)]), msg) + case(5) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 5)]), msg) + case(6) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 6)]), msg) + case(7) + call shr_assert_any(reshape(array, [(dimsize, i = 1, 7)]), msg) + case default + call throw("assert_any_wrapper was given a bad rank.") + end select + +end subroutine assert_any_wrapper + +end module test_assert_array diff --git a/share/csm_share/test/unit/shr_assert_test/test_macro.pf b/share/csm_share/test/unit/shr_assert_test/test_macro.pf new file mode 100644 index 000000000000..87581d7a4d81 --- /dev/null +++ b/share/csm_share/test/unit/shr_assert_test/test_macro.pf @@ -0,0 +1,52 @@ +module test_macro + +! Test that if NDEBUG is not defined, shr_assert macros run assertions. + +use pfunit_mod + +#undef NDEBUG +#include "shr_assert.h" + +contains + +@Test +subroutine macro_assert_can_pass() + SHR_ASSERT(.true., "Assert macro unexpectedly aborted!") +end subroutine macro_assert_can_pass + +@Test +subroutine macro_assert_can_fail() + SHR_ASSERT(.false., "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine macro_assert_can_fail + +@Test +subroutine macro_assert_all_can_pass() + SHR_ASSERT_ALL(([.true., .true.]), "Assert macro unexpectedly aborted!") +end subroutine macro_assert_all_can_pass + +@Test +subroutine macro_assert_all_can_fail() + SHR_ASSERT_ALL(([.true., .false.]), "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine macro_assert_all_can_fail + +@Test +subroutine macro_assert_any_can_pass() + SHR_ASSERT_ANY(([.true., .false.]), "Assert macro unexpectedly aborted!") +end subroutine macro_assert_any_can_pass + +@Test +subroutine macro_assert_any_can_fail() + SHR_ASSERT_ANY(([.false., .false.]), "Expected failure.") + ! When this was written, the preprocessor did not recognize this assert, + ! so call it directly instead of using an "@". + call assertExceptionRaised("ABORTED: Expected failure.") +end subroutine macro_assert_any_can_fail + + +end module test_macro diff --git a/share/csm_share/test/unit/shr_assert_test/test_ndebug.pf b/share/csm_share/test/unit/shr_assert_test/test_ndebug.pf new file mode 100644 index 000000000000..9f90fcf5bc1f --- /dev/null +++ b/share/csm_share/test/unit/shr_assert_test/test_ndebug.pf @@ -0,0 +1,45 @@ +module test_ndebug + +! Test that if NDEBUG is defined, shr_assert macros do nothing. + +use pfunit_mod + +#define NDEBUG +#include "shr_assert.h" + +contains + +@Test +subroutine ndebug_controls_assert_macro() + SHR_ASSERT(unreachable_function(), "Fake message.") +contains + logical function unreachable_function() + unreachable_function = .false. + call throw("NDEBUG failed to turn off SHR_ASSERT.", & + SourceLocation(__FILE__, __LINE__)) + end function unreachable_function +end subroutine ndebug_controls_assert_macro + +@Test +subroutine ndebug_controls_assert_all_macro() + SHR_ASSERT_ALL(unreachable_function(), "Fake message.") +contains + logical function unreachable_function() + unreachable_function = .false. + call throw("NDEBUG failed to turn off SHR_ASSERT_ALL.", & + SourceLocation(__FILE__, __LINE__)) + end function unreachable_function +end subroutine ndebug_controls_assert_all_macro + +@Test +subroutine ndebug_controls_assert_any_macro() + SHR_ASSERT_ANY(unreachable_function(), "Fake message.") +contains + logical function unreachable_function() + unreachable_function = .false. + call throw("NDEBUG failed to turn off SHR_ASSERT_ANY.", & + SourceLocation(__FILE__, __LINE__)) + end function unreachable_function +end subroutine ndebug_controls_assert_any_macro + +end module test_ndebug diff --git a/share/csm_share/test/unit/shr_infnan_test/CMakeLists.txt b/share/csm_share/test/unit/shr_infnan_test/CMakeLists.txt new file mode 100644 index 000000000000..aa0bcafe3277 --- /dev/null +++ b/share/csm_share/test/unit/shr_infnan_test/CMakeLists.txt @@ -0,0 +1,31 @@ +set(test_sources test_infnan.F90) + +set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +add_executable(infnan_test_exe ${test_sources}) + +declare_generated_dependencies(infnan_test_exe "${share_genf90_sources}") + +if("${CMAKE_BUILD_TYPE}" MATCHES CESM_DEBUG) + set(FPES_ARE_TRAPPED TRUE) +endif() + +if(NOT FPES_ARE_TRAPPED) + + # Add the actual test. + add_test(infnan infnan_test_exe) + + define_Fortran_stop_failure(infnan) + +else() + + # CESM_DEBUG turns on floating point trapping, causing checks in this + # test to fail. We'd like the users to be able to see that the test + # was skipped but didn't fail, but CTest has no mechanism for this. + # Instead, hack around it by adding a test that will always pass but + # is likely to stand out as a skipped test. + add_test(SKIPPED_infnan true) + +endif() diff --git a/share/csm_share/test/unit/shr_infnan_test/test_infnan.F90 b/share/csm_share/test/unit/shr_infnan_test/test_infnan.F90 new file mode 100644 index 000000000000..3a1851cab708 --- /dev/null +++ b/share/csm_share/test/unit/shr_infnan_test/test_infnan.F90 @@ -0,0 +1,157 @@ +program test_infnan + +! +! This is a test for the shr_infnan_mod module. It was created using the +! pre-CTest system, with minimal changes to keep it working. So it may not +! be a great example of a CTest test now. +! + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_kind_mod, only: r4 => shr_kind_r4 +use shr_kind_mod, only: i8 => shr_kind_i8 +use shr_kind_mod, only: i4 => shr_kind_i4 +use shr_infnan_mod + +implicit none + +real(r8) :: x, zero +real(r4) :: y +real(r8) :: r8array(100), r82Darray(10,10), r83Darray(4,4,4) +real(r8) :: r84Darray(3,3,3,3), r85Darray(2,2,2,2,2) +real(r8) :: inf +real(r8) :: nan +real(r8) :: nans +real(r4) :: spnan +real(r4) :: spnans +integer(i8), parameter :: dpinfpat = int(O'0777600000000000000000',i8) +integer(i8), parameter :: dpnanpat = int(O'0777700000000000000000',i8) +integer(i8), parameter :: dpnanspat = int(O'0777610000000000000000',i8) +integer(i4), parameter :: spnanpat = int(Z'7FC00000',i4) +integer(i4), parameter :: spnanspat = int(Z'7FC10000',i4) +intrinsic :: count + +inf = transfer(dpinfpat,inf) +nan = transfer(dpnanpat,nan) +nans = transfer(dpnanspat,nans) +spnan = transfer( spnanpat,spnan) +spnans = transfer( spnanspat,spnans) + +x = 0.0 +zero = 0.0 + +call assert( shr_infnan_isnan( nan ), "Test that value set to nan is nan" ) +call assert( shr_infnan_isnan( nans ), "Test that value set to nans is nan" ) +call assert( shr_infnan_isnan( spnan ), "Test that value set to sp nan is nan" ) +call assert( shr_infnan_isnan( spnans ), "Test that value set to sp nans is nan" ) +call assert( .not. shr_infnan_isnan( 1.0_r8 ), "Test that value set to one is NOT nan" ) +call assert( .not. shr_infnan_isnan( 1.0_r4 ), "Test that value set to SP one is NOT nan" ) +call assert( .not. shr_infnan_isnan( huge(x) ), "Test that value set to huge is NOT nan" ) +x = 1.0/zero +call assert( .not. shr_infnan_isnan( x ), "Test that 1/0 is NOT nan" ) +x = -1.0/zero +call assert( .not. shr_infnan_isnan( x ), "Test that -1/0 is NOT nan" ) + +r8array(:) = 1.0d00 +r8array(10) = nan +r8array(15) = nan +r82Darray(:,:) = 1.0d00 +r82Darray(5,5) = nan +r82Darray(10,7) = nan +r82Darray(7,9) = nan +r83Darray(:,:,:) = 1.0d00 +r83Darray(4,2,2) = nan +r83Darray(3,1,2) = nan +r83Darray(1,1,1) = nan +r83Darray(1,1,4) = nan +r84Darray(:,:,:,:) = 1.0d00 +r84Darray(3,2,2,1) = nan +r84Darray(3,1,2,1) = nan +r84Darray(1,1,1,1) = nan +r84Darray(1,1,3,1) = nan +r84Darray(1,2,3,1) = nan +r85Darray(:,:,:,:,:) = 1.0d00 +r85Darray(1,2,2,1,1) = nan +r85Darray(1,1,2,1,2) = nan +r85Darray(1,1,1,2,1) = nan +r85Darray(1,2,2,2,1) = nan +r85Darray(1,2,1,1,2) = nan +r85Darray(1,1,1,1,1) = nan +call assert( any(shr_infnan_isnan( r8array )), "Test that array with 2 nans is nan" ) +call assert( count(shr_infnan_isnan( r8array )) == 2, "Test that there are 2 nans in that array" ) +call assert( any(shr_infnan_isnan( r82Darray )), "Test that 2D array with 3 nans is nan" ) +call assert( count(shr_infnan_isnan( r82Darray )) == 3, "Test that there are 3 nans in that array" ) +call assert( any(shr_infnan_isnan( r83Darray )), "Test that 3D array with 4 nans is nan" ) +call assert( count(shr_infnan_isnan( r83Darray )) == 4, "Test that there are 4 nans in that array" ) +call assert( any(shr_infnan_isnan( r84Darray )), "Test that 4D array with 5 nans is nan" ) +call assert( count(shr_infnan_isnan( r84Darray )) == 5, "Test that there are 5 nans in that array" ) +call assert( any(shr_infnan_isnan( r85Darray )), "Test that 5D array with 6 nans is nan" ) +call assert( count(shr_infnan_isnan( r85Darray )) == 6, "Test that there are 6 nans in that array" ) +call assert( shr_infnan_isposinf( inf ), "Test that value set to inf is inf" ) +call assert( .not. shr_infnan_isposinf( 1.0_r8 ), "Test that value set to one is NOT inf" ) +call assert( .not. shr_infnan_isposinf( 1.0_r4 ), "Test that value set to SP one is NOT inf" ) +call assert( shr_infnan_isneginf( -inf ), "Test that value set to -inf is -inf" ) +call assert( .not. shr_infnan_isneginf( 1.0_r8 ), "Test that value set to one is NOT -inf" ) +call assert( .not. shr_infnan_isneginf( 1.0_r4 ), "Test that value set to SP one is NOT -inf" ) +x = 1.0/zero +call assert( shr_infnan_isposinf( x ), "Test that 1/0 is inf" ) +x = -1.0/zero +call assert( shr_infnan_isneginf( x ), "Test that -1/0 is -inf" ) + +x = -1.0 +call assert( shr_infnan_isnan( sqrt(x) ), "Test that sqrt-1 is nan" ) +call assert( shr_infnan_isnan( log(x) ), "Test that log-1 is nan" ) + +x = shr_infnan_nan +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_nan sets r8 to nan" ) +y = shr_infnan_nan +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_nan sets r4 to nan" ) + +x = shr_infnan_inf +call assert( shr_infnan_isinf( x ), "Test that shr_infnan_inf sets r8 to inf" ) +y = shr_infnan_inf +call assert( shr_infnan_isinf( y ), "Test that shr_infnan_inf sets r4 to inf" ) + +x = shr_infnan_posinf +call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_posinf sets r8 to +inf" ) +y = shr_infnan_posinf +call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_posinf sets r4 to +inf" ) + +x = shr_infnan_neginf +call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_neginf sets r8 to -inf" ) +y = shr_infnan_neginf +call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_neginf sets r4 to -inf" ) + +x = shr_infnan_to_r8(shr_infnan_qnan) +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_qnan) sets r8 to nan" ) +y = shr_infnan_to_r4(shr_infnan_qnan) +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_qnan) sets r4 to nan" ) + +x = shr_infnan_to_r8(shr_infnan_snan) +call assert( shr_infnan_isnan( x ), "Test that shr_infnan_to_r8(shr_infnan_snan) sets r8 to nan" ) +y = shr_infnan_to_r4(shr_infnan_snan) +call assert( shr_infnan_isnan( y ), "Test that shr_infnan_to_r4(shr_infnan_snan) sets r4 to nan" ) + +x = shr_infnan_to_r8(shr_infnan_posinf) +call assert( shr_infnan_isposinf( x ), "Test that shr_infnan_to_r8(shr_infnan_posinf) sets r8 to +inf" ) +y = shr_infnan_to_r4(shr_infnan_posinf) +call assert( shr_infnan_isposinf( y ), "Test that shr_infnan_to_r4(shr_infnan_posinf) sets r4 to +inf" ) + +x = shr_infnan_to_r8(shr_infnan_neginf) +call assert( shr_infnan_isneginf( x ), "Test that shr_infnan_to_r8(shr_infnan_neginf) sets r8 to -inf" ) +y = shr_infnan_to_r4(shr_infnan_neginf) +call assert( shr_infnan_isneginf( y ), "Test that shr_infnan_to_r4(shr_infnan_neginf) sets r4 to -inf" ) + +contains + + subroutine assert(val, msg) + logical, intent(in) :: val + character(len=*), intent(in) :: msg + + if (.not. val) then + print *, msg + stop 1 + end if + + end subroutine assert + +end program test_infnan diff --git a/share/csm_share/test/unit/shr_log_test/CMakeLists.txt b/share/csm_share/test/unit/shr_log_test/CMakeLists.txt new file mode 100644 index 000000000000..9a2c03d45eac --- /dev/null +++ b/share/csm_share/test/unit/shr_log_test/CMakeLists.txt @@ -0,0 +1,12 @@ +set(pf_sources + test_error_printers.pf) + +set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 + shr_strconvert_mod.F90 shr_log_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +create_pFUnit_test(shr_log shr_log_exe "${pf_sources}" + "${test_sources}") + +declare_generated_dependencies(shr_log_exe "${share_genf90_sources}") diff --git a/share/csm_share/test/unit/shr_log_test/test_error_printers.pf b/share/csm_share/test/unit/shr_log_test/test_error_printers.pf new file mode 100644 index 000000000000..db4afff0b178 --- /dev/null +++ b/share/csm_share/test/unit/shr_log_test/test_error_printers.pf @@ -0,0 +1,51 @@ +module test_error_printers + +use pfunit_mod + +! Tests for routines that create error messages. We obviously can't automate the +! process of deciding whether a message is correct or helpful, but we can test +! that the information provided is actually put into the output. + +use shr_kind_mod, only: cx => shr_kind_cx + +use shr_strconvert_mod, only: toString + +implicit none + +contains + +@Test +subroutine errMsg_prints_arguments() + use shr_log_mod, only: shr_log_errMsg + + character(len=*), parameter :: file_name = "foo.F90" + integer, parameter :: line_no = 20 + + character(len=cx) :: error_string + + error_string = shr_log_errMsg(file_name, line_no) + + @assertLessThan(0, index(error_string, file_name)) + @assertLessThan(0, index(error_string, toString(line_no))) + +end subroutine errMsg_prints_arguments + +@Test +subroutine OOBMsg_prints_arguments() + use shr_log_mod, only: shr_log_OOBMsg + + character(len=*), parameter :: operation = "foo" + integer, parameter :: bounds(2) = [2, 3], idx = 5 + + character(len=cx) :: error_string + + error_string = shr_log_OOBMsg(operation, bounds, idx) + + @assertLessThan(0, index(error_string, operation)) + @assertLessThan(0, index(error_string, toString(bounds(1)))) + @assertLessThan(0, index(error_string, toString(bounds(2)))) + @assertLessThan(0, index(error_string, toString(idx))) + +end subroutine OOBMsg_prints_arguments + +end module test_error_printers diff --git a/share/csm_share/test/unit/shr_precip_test/CMakeLists.txt b/share/csm_share/test/unit/shr_precip_test/CMakeLists.txt new file mode 100644 index 000000000000..ab71f8efc7c3 --- /dev/null +++ b/share/csm_share/test/unit/shr_precip_test/CMakeLists.txt @@ -0,0 +1,12 @@ +# Local pFUnit files. +set(pf_sources + test_shr_precip.pf) + +# Sources to test. +set(sources_needed + shr_kind_mod.F90 shr_const_mod.F90 shr_precip_mod.F90) +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +# Do source preprocessing and add the executable. +create_pFUnit_test(shr_precip_mod shr_precip_mod_exe "${pf_sources}" + "${test_sources}") diff --git a/share/csm_share/test/unit/shr_precip_test/test_shr_precip.pf b/share/csm_share/test/unit/shr_precip_test/test_shr_precip.pf new file mode 100644 index 000000000000..cb5bcd996040 --- /dev/null +++ b/share/csm_share/test/unit/shr_precip_test/test_shr_precip.pf @@ -0,0 +1,62 @@ +module test_shr_precip + + ! Tests of shr_precip_mod + + use pfunit_mod + use shr_precip_mod + use shr_kind_mod, only : r8 => SHR_KIND_R8 + use shr_const_mod, only : SHR_CONST_TKFRZ + + implicit none + + @TestCase + type, extends(TestCase) :: TestShrPrecip + contains + procedure :: setUp + procedure :: tearDown + end type TestShrPrecip + + real(r8), parameter :: tol = 1.e-13_r8 + +contains + + subroutine setUp(this) + class(TestShrPrecip), intent(inout) :: this + end subroutine setUp + + subroutine tearDown(this) + class(TestShrPrecip), intent(inout) :: this + end subroutine tearDown + + ! ------------------------------------------------------------------------ + ! Tests of shr_precip_partition_rain_snow_ramp + ! ------------------------------------------------------------------------ + + @Test + subroutine partition_rain_snow_ramp_allSnow(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(273._r8, frac_rain) + @assertEqual(0._r8, frac_rain) + end subroutine partition_rain_snow_ramp_allSnow + + @Test + subroutine partition_rain_snow_ramp_allRain(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(276._r8, frac_rain) + @assertEqual(1._r8, frac_rain) + end subroutine partition_rain_snow_ramp_allRain + + @Test + subroutine partition_rain_snow_ramp_mixture(this) + class(TestShrPrecip), intent(inout) :: this + real(r8) :: frac_rain + + call shr_precip_partition_rain_snow_ramp(SHR_CONST_TKFRZ + 1.5_r8, frac_rain) + @assertEqual(0.75_r8, frac_rain, tolerance=tol) + end subroutine partition_rain_snow_ramp_mixture + +end module test_shr_precip diff --git a/share/csm_share/test/unit/shr_spfn_test/CMakeLists.txt b/share/csm_share/test/unit/shr_spfn_test/CMakeLists.txt new file mode 100644 index 000000000000..4d80da799469 --- /dev/null +++ b/share/csm_share/test/unit/shr_spfn_test/CMakeLists.txt @@ -0,0 +1,12 @@ +set(pf_sources test_erf_r4.pf test_erf_r8.pf test_gamma_factorial.pf + test_igamma.pf) + +set(sources_needed shr_kind_mod.F90 shr_const_mod.F90 shr_infnan_mod.F90 + shr_strconvert_mod.F90 shr_log_mod.F90 + shr_sys_mod.nompi_abortthrows.F90 shr_spfn_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +create_pFUnit_test(spfn spfn_test_exe "${pf_sources}" "${test_sources}") + +declare_generated_dependencies(spfn_test_exe "${share_genf90_sources}") diff --git a/share/csm_share/test/unit/shr_spfn_test/test_erf_r4.pf b/share/csm_share/test/unit/shr_spfn_test/test_erf_r4.pf new file mode 100644 index 000000000000..be0382f123ef --- /dev/null +++ b/share/csm_share/test/unit/shr_spfn_test/test_erf_r4.pf @@ -0,0 +1,132 @@ +module test_erf_r4 + +use pfunit_mod + +use shr_kind_mod, only: & + r4 => shr_kind_r4 + +use shr_spfn_mod, only: & + erf => shr_spfn_erf, & + erfc => shr_spfn_erfc, & + erfc_scaled => shr_spfn_erfc_scaled + +implicit none +save + +! Approximately what (negative) number makes erfc_scaled overflow? +real(r4), parameter :: erfc_scaled_overflow = 9._r4 + +@TestParameter +type, extends(AbstractTestParameter) :: ErfR4Params + real(r4) :: test_point + real(r4) :: erf_val + real(r4) :: tol = 0._r4 + contains + procedure :: toString +end type ErfR4Params + +@TestCase(testParameters={getParameters()}, constructor=new_TestErfR4) +type, extends(ParameterizedTestCase) :: TestErfR4 + real(r4) :: test_point + real(r4) :: erf_val + real(r4) :: tol +end type TestErfR4 + +contains + +function new_TestErfR4(params) result(test) + type(ErfR4Params), intent(in) :: params + type(TestErfR4) :: test + + test%test_point = params%test_point + test%erf_val = params%erf_val + test%tol = params%tol + +end function new_TestErfR4 + +function getParameters() result(params) + type(ErfR4Params), allocatable :: params(:) + + params = [ & + ErfR4Params(0._r4, 0._r4), & + ErfR4Params(15._r4, 1._r4), & + ErfR4Params(-15._r4, -1._r4), & + ErfR4Params(1._r4, 0.842700792949714869341, tol=1.e-5_r4), & + ErfR4Params(-1._r4, -0.842700792949714869341, tol=1.e-5_r4) ] + +end function getParameters + +function toString(this) result(string) + class(ErfR4Params), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, '(A,F8.4,A,F8.4,A)') & + "(point = ",this%test_point,", erf = ",this%erf_val,")" + + string = trim(buffer) + +end function toString + +! Check that the erf function gets the expected result. +@Test +subroutine erf_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) +end subroutine erf_r4_has_correct_value + +! Check that two runs of the erf function get identical results. +@Test +subroutine erf_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(erf(this%test_point), erf(this%test_point)) +end subroutine erf_r4_is_reproducible + +! Check that erfc(x) = 1 - erf(x). +@Test +subroutine erfc_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(1._r4 - this%erf_val, erfc(this%test_point), tolerance=this%tol) +end subroutine erfc_r4_has_correct_value + +! Check that two runs of the erfc function get identical results. +@Test +subroutine erfc_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + @assertEqual(erfc(this%test_point), erfc(this%test_point)) +end subroutine erfc_r4_is_reproducible + +! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). +@Test +subroutine erfc_scaled_r4_has_correct_value(this) + class(TestErfR4), intent(inout) :: this + real(r4) :: erfc_scaled_expected + + ! Distinguish between where the test point has a modest value, or is too + ! big to use a naive calculation. + if (abs(this%test_point) < erfc_scaled_overflow) then + erfc_scaled_expected = exp(this%test_point**2)*(1._r4 - this%erf_val) + else + ! For larger positive values, we could use an approximation, but this + ! is not trivial. Large negative values should overflow; the only + ! thing we could possibly check in that case would be to ensure that + ! the implementation throws a floating-point error. + + ! For now, just automatically pass the test for large values. + return + end if + + @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) +end subroutine erfc_scaled_r4_has_correct_value + +! Check that two runs of the erfc_scaled function get identical results. +@Test +subroutine erfc_scaled_r4_is_reproducible(this) + class(TestErfR4), intent(inout) :: this + ! Skip this if we overflow. + if (this%test_point < -erfc_scaled_overflow) return + @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) +end subroutine erfc_scaled_r4_is_reproducible + +end module test_erf_r4 diff --git a/share/csm_share/test/unit/shr_spfn_test/test_erf_r8.pf b/share/csm_share/test/unit/shr_spfn_test/test_erf_r8.pf new file mode 100644 index 000000000000..fc5f1b3e1c49 --- /dev/null +++ b/share/csm_share/test/unit/shr_spfn_test/test_erf_r8.pf @@ -0,0 +1,132 @@ +module test_erf_r8 + +use pfunit_mod + +use shr_kind_mod, only: & + r8 => shr_kind_r8 + +use shr_spfn_mod, only: & + erf => shr_spfn_erf, & + erfc => shr_spfn_erfc, & + erfc_scaled => shr_spfn_erfc_scaled + +implicit none +save + +! Approximately what (negative) number makes erfc_scaled overflow? +real(r8), parameter :: erfc_scaled_overflow = 26._r8 + +@TestParameter +type, extends(AbstractTestParameter) :: ErfR8Params + real(r8) :: test_point + real(r8) :: erf_val + real(r8) :: tol = 0._r8 + contains + procedure :: toString +end type ErfR8Params + +@TestCase(testParameters={getParameters()}, constructor=new_TestErfR8) +type, extends(ParameterizedTestCase) :: TestErfR8 + real(r8) :: test_point + real(r8) :: erf_val + real(r8) :: tol +end type TestErfR8 + +contains + +function new_TestErfR8(params) result(test) + type(ErfR8Params), intent(in) :: params + type(TestErfR8) :: test + + test%test_point = params%test_point + test%erf_val = params%erf_val + test%tol = params%tol + +end function new_TestErfR8 + +function getParameters() result(params) + type(ErfR8Params), allocatable :: params(:) + + params = [ & + ErfR8Params(0._r8, 0._r8), & + ErfR8Params(30._r8, 1._r8), & + ErfR8Params(-30._r8, -1._r8), & + ErfR8Params(1._r8, 0.842700792949714869341, tol=1.e-6_r8), & + ErfR8Params(-1._r8, -0.842700792949714869341, tol=1.e-6_r8) ] + +end function getParameters + +function toString(this) result(string) + class(ErfR8Params), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, '(A,F8.4,A,F8.4,A)') & + "(point = ",this%test_point,", erf = ",this%erf_val,")" + + string = trim(buffer) + +end function toString + +! Check that the erf function gets the expected result. +@Test +subroutine erf_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(this%erf_val, erf(this%test_point), tolerance=this%tol) +end subroutine erf_r8_has_correct_value + +! Check that two runs of the erf function get identical results. +@Test +subroutine erf_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(erf(this%test_point), erf(this%test_point)) +end subroutine erf_r8_is_reproducible + +! Check that erfc(x) = 1 - erf(x). +@Test +subroutine erfc_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(1._r8 - this%erf_val, erfc(this%test_point), tolerance=this%tol) +end subroutine erfc_r8_has_correct_value + +! Check that two runs of the erfc function get identical results. +@Test +subroutine erfc_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + @assertEqual(erfc(this%test_point), erfc(this%test_point)) +end subroutine erfc_r8_is_reproducible + +! Check that erfc_scaled(x) = exp(x**2) * (1 - erf(x)). +@Test +subroutine erfc_scaled_r8_has_correct_value(this) + class(TestErfR8), intent(inout) :: this + real(r8) :: erfc_scaled_expected + + ! Distinguish between where the test point has a modest value, or is too + ! big to use a naive calculation. + if (abs(this%test_point) < erfc_scaled_overflow) then + erfc_scaled_expected = exp(this%test_point**2)*(1._r8 - this%erf_val) + else + ! For larger positive values, we could use an approximation, but this + ! is not trivial. Large negative values should overflow; the only + ! thing we could possibly check in that case would be to ensure that + ! the implementation throws a floating-point error. + + ! For now, just automatically pass the test for large values. + return + end if + + @assertEqual(erfc_scaled_expected, erfc_scaled(this%test_point), tolerance=this%tol) +end subroutine erfc_scaled_r8_has_correct_value + +! Check that two runs of the erfc_scaled function get identical results. +@Test +subroutine erfc_scaled_r8_is_reproducible(this) + class(TestErfR8), intent(inout) :: this + ! Skip this if we overflow. + if (this%test_point < -erfc_scaled_overflow) return + @assertEqual(erfc_scaled(this%test_point), erfc_scaled(this%test_point)) +end subroutine erfc_scaled_r8_is_reproducible + +end module test_erf_r8 diff --git a/share/csm_share/test/unit/shr_spfn_test/test_gamma_factorial.pf b/share/csm_share/test/unit/shr_spfn_test/test_gamma_factorial.pf new file mode 100644 index 000000000000..a057617ad323 --- /dev/null +++ b/share/csm_share/test/unit/shr_spfn_test/test_gamma_factorial.pf @@ -0,0 +1,98 @@ +module test_gamma_factorial + +use pfunit_mod + +use shr_kind_mod, only: & + r8 => shr_kind_r8, & + i8 => shr_kind_i8 + +use shr_spfn_mod, only: & + gamma => shr_spfn_gamma, & + igamma => shr_spfn_igamma + +implicit none +save + +real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 + +@TestParameter +type, extends(AbstractTestParameter) :: GammaTestInt + integer :: test_int + contains + procedure :: toString +end type GammaTestInt + +@TestCase(testParameters={getParameters()}, constructor=new_TestGammaFac) +type, extends(ParameterizedTestCase) :: TestGammaFac + real(r8) :: input_int + real(r8) :: test_factorial +end type TestGammaFac + +contains + +function new_TestGammaFac(params) result(test) + type(GammaTestInt), intent(in) :: params + type(TestGammaFac) :: test + + test%input_int = real(params%test_int,r8) + + ! A curious fact; because the factorial contains so many powers of 2, 20! + ! is exactly representable in an 8 byte double even though it is bigger + ! than 1/epsilon. + test%test_factorial = real(factorial(params%test_int-1),r8) + +contains + + function factorial(n) + integer, intent(in) :: n + integer(i8) :: factorial + integer(i8) :: i + factorial = product([( i, i = 1, n )]) + end function factorial + +end function new_TestGammaFac + +function getParameters() result(params) + type(GammaTestInt), allocatable :: params(:) + + integer :: i + + params = [( GammaTestInt(i), i = 1, 21 )] + +end function getParameters + +function toString(this) result(string) + class(GammaTestInt), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer, *) "(n = ",this%test_int,")" + + string = trim(buffer) + +end function toString + +@Test +subroutine gamma_is_factorial(this) + class(TestGammaFac), intent(inout) :: this + + real(r8) :: tol + + tol = relative_error_tolerance * this%test_factorial + + @assertEqual(this%test_factorial, gamma(this%input_int), tolerance=tol) +end subroutine gamma_is_factorial + +@Test +subroutine igamma_is_factorial(this) + class(TestGammaFac), intent(inout) :: this + + real(r8) :: tol + + tol = relative_error_tolerance * this%test_factorial + + @assertEqual(this%test_factorial, igamma(this%input_int,0._r8), tolerance=tol) +end subroutine igamma_is_factorial + +end module test_gamma_factorial diff --git a/share/csm_share/test/unit/shr_spfn_test/test_igamma.pf b/share/csm_share/test/unit/shr_spfn_test/test_igamma.pf new file mode 100644 index 000000000000..3a292a3a5cc4 --- /dev/null +++ b/share/csm_share/test/unit/shr_spfn_test/test_igamma.pf @@ -0,0 +1,42 @@ +module test_igamma + +use pfunit_mod + +use shr_kind_mod, only: & + r8 => shr_kind_r8 + +use shr_const_mod, only: & + pi => shr_const_pi + +use shr_spfn_mod, only: & + igamma => shr_spfn_igamma, & + erfc => shr_spfn_erfc + +implicit none +save + +real(r8), parameter :: relative_error_tolerance = 1.e-12_r8 + +contains + +! igamma(1,x) = exp(-x) +! => igamma(1,1) = exp(-1) +@Test +subroutine igamma_matches_exp_1() + real(r8) :: tol + tol = relative_error_tolerance*exp(-1._r8) + @assertEqual(exp(-1._r8), igamma(1._r8, 1._r8), tolerance=tol) +end subroutine igamma_matches_exp_1 + +! igamma(1/2,x) = sqrt(pi)*erfc(sqrt(x)) +! => igamma(0.5,1) = sqrt(pi)*erfc(1) +@Test +subroutine igamma_matches_erfc_1() + real(r8) :: expected + real(r8) :: tol + expected = sqrt(pi)*erfc(1._r8) + tol = relative_error_tolerance*expected + @assertEqual(expected, igamma(0.5_r8, 1._r8), tolerance=tol) +end subroutine igamma_matches_erfc_1 + +end module test_igamma diff --git a/share/csm_share/test/unit/shr_strconvert_test/CMakeLists.txt b/share/csm_share/test/unit/shr_strconvert_test/CMakeLists.txt new file mode 100644 index 000000000000..dd3fad19bda9 --- /dev/null +++ b/share/csm_share/test/unit/shr_strconvert_test/CMakeLists.txt @@ -0,0 +1,12 @@ +set(pf_sources + test_toString.pf) + +set(sources_needed shr_kind_mod.F90 shr_infnan_mod.F90 + shr_strconvert_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +create_pFUnit_test(shr_strconvert shr_strconvert_exe "${pf_sources}" + "${test_sources}") + +declare_generated_dependencies(shr_strconvert_exe "${share_genf90_sources}") diff --git a/share/csm_share/test/unit/shr_strconvert_test/test_toString.pf b/share/csm_share/test/unit/shr_strconvert_test/test_toString.pf new file mode 100644 index 000000000000..441c6b18930c --- /dev/null +++ b/share/csm_share/test/unit/shr_strconvert_test/test_toString.pf @@ -0,0 +1,165 @@ +module test_toString + +! Simple tests for printing intrinsic types. +! +! This module is somewhat repetitive, but it seems manageable enough that it's +! not worth invoking complex methods such as genf90, cpp hacks, or parameterized +! pFUnit tests to handle the different types. + +use pfunit_mod + +use shr_kind_mod, only: & + i4 => shr_kind_i4, & + i8 => shr_kind_i8, & + r4 => shr_kind_r4, & + r8 => shr_kind_r8 + +use shr_infnan_mod, only: & + posinf => shr_infnan_posinf, & + neginf => shr_infnan_neginf, & + qnan => shr_infnan_qnan, & + snan => shr_infnan_snan, & + to_r4 => shr_infnan_to_r4, & + to_r8 => shr_infnan_to_r8 + +use shr_strconvert_mod, only: toString + +implicit none + +contains + +@Test +subroutine toString_prints_i4() + @assertEqual("1", toString(1_i4)) +end subroutine toString_prints_i4 + +@Test +subroutine toString_prints_i4_longest_value() + @assertEqual("-2147483648", toString(-huge(1_i4)-1_i4)) +end subroutine toString_prints_i4_longest_value + +@Test +subroutine toString_prints_i4_with_format() + @assertEqual("00001", toString(1_i4, format_string="(I0.5)")) +end subroutine toString_prints_i4_with_format + +@Test +subroutine toString_prints_i8() + @assertEqual("1", toString(1_i8)) +end subroutine toString_prints_i8 + +@Test +subroutine toString_prints_i8_longest_value() + @assertEqual("-9223372036854775808", toString(-huge(1_i8)-1_i8)) +end subroutine toString_prints_i8_longest_value + +@Test +subroutine toString_prints_i8_with_format() + @assertEqual("00001", toString(1_i8, format_string="(I0.5)")) +end subroutine toString_prints_i8_with_format + +@Test +subroutine toString_prints_positive_r4() + @assertEqual("+1.00000000E+00", toString(1._r4)) +end subroutine toString_prints_positive_r4 + +@Test +subroutine toString_prints_negative_r4() + @assertEqual("-1.00000000E+00", toString(-1._r4)) +end subroutine toString_prints_negative_r4 + +@Test +subroutine toString_prints_positive_infinity_r4() + character(len=:), allocatable :: string + string = toString(to_r4(posinf)) + @assertEqual("+Inf", string(1:4)) +end subroutine toString_prints_positive_infinity_r4 + +@Test +subroutine toString_prints_negative_infinity_r4() + character(len=:), allocatable :: string + string = toString(to_r4(neginf)) + @assertEqual("-Inf", string(1:4)) +end subroutine toString_prints_negative_infinity_r4 + +@Test +subroutine toString_prints_qnan_r4() + character(len=:), allocatable :: string + string = toString(to_r4(qnan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_qnan_r4 + +@Test +subroutine toString_prints_snan_r4() + character(len=:), allocatable :: string + string = toString(to_r4(snan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_snan_r4 + +@Test +subroutine toString_prints_r4_with_format() + ! Compiler-specific printing conventions, like the optional leading "+", or + ! putting a "0" before a leading decimal point, are not standardized if + ! format_string is specified. Therefore, pick a value that's not subject to + ! these compiler-defined behaviors. + @assertEqual("-1.50", toString(-1.5_r4, format_string="(F5.2)")) +end subroutine toString_prints_r4_with_format + +@Test +subroutine toString_prints_positive_r8() + @assertEqual("+1.0000000000000000E+000", toString(1._r8)) +end subroutine toString_prints_positive_r8 + +@Test +subroutine toString_prints_negative_r8() + @assertEqual("-1.0000000000000000E+000", toString(-1._r8)) +end subroutine toString_prints_negative_r8 + +@Test +subroutine toString_prints_positive_infinity_r8() + character(len=:), allocatable :: string + string = toString(to_r8(posinf)) + @assertEqual("+Inf", string(1:4)) +end subroutine toString_prints_positive_infinity_r8 + +@Test +subroutine toString_prints_negative_infinity_r8() + character(len=:), allocatable :: string + string = toString(to_r8(neginf)) + @assertEqual("-Inf", string(1:4)) +end subroutine toString_prints_negative_infinity_r8 + +@Test +subroutine toString_prints_qnan_r8() + character(len=:), allocatable :: string + string = toString(to_r8(qnan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_qnan_r8 + +@Test +subroutine toString_prints_snan_r8() + character(len=:), allocatable :: string + string = toString(to_r8(snan)) + @assertLessThan(0, len(string), message="String is empty!") + @assertEqual("NaN", string(1:3)) +end subroutine toString_prints_snan_r8 + +@Test +subroutine toString_prints_r8_with_format() + ! Compiler-specific printing conventions, like the optional leading "+", or + ! putting a "0" before a leading decimal point, are not standardized if + ! format_string is specified. Therefore, pick a value that's not subject to + ! these compiler-defined behaviors. + @assertEqual("-1.50", toString(-1.5_r8, format_string="(F5.2)")) +end subroutine toString_prints_r8_with_format + +@Test +subroutine toString_prints_logical() + @assertEqual("T", toString(.true.)) + @assertEqual("F", toString(.false.)) +end subroutine toString_prints_logical + +end module test_toString diff --git a/share/csm_share/test/unit/shr_string_test/CMakeLists.txt b/share/csm_share/test/unit/shr_string_test/CMakeLists.txt new file mode 100644 index 000000000000..9078478058c9 --- /dev/null +++ b/share/csm_share/test/unit/shr_string_test/CMakeLists.txt @@ -0,0 +1,19 @@ +set (pf_sources + test_shr_string.pf + ) + +set(sources_needed + shr_string_mod.F90 + shr_assert_mod.F90 + shr_infnan_mod.F90 + shr_kind_mod.F90 + shr_log_mod.F90 + shr_strconvert_mod.F90 + shr_sys_mod.nompi_abortthrows.F90 + shr_timer_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +create_pFUnit_test(shr_string shr_string_exe "${pf_sources}" "${test_sources}") + +declare_generated_dependencies(shr_string_exe "${share_genf90_sources}") \ No newline at end of file diff --git a/share/csm_share/test/unit/shr_string_test/test_shr_string.pf b/share/csm_share/test/unit/shr_string_test/test_shr_string.pf new file mode 100644 index 000000000000..500cd169d215 --- /dev/null +++ b/share/csm_share/test/unit/shr_string_test/test_shr_string.pf @@ -0,0 +1,89 @@ +module test_shr_string + + ! Tests of shr_string_mod + + use pfunit_mod + use shr_string_mod + + implicit none + + integer, parameter :: list_len = 256 + +contains + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listDiff + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listDiff_default() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'fourth:second', & + listout = actual) + @assertEqual('first:third', actual) + end subroutine test_shr_string_listDiff_default + + @Test + subroutine test_shr_string_listDiff_emptyList2() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = ' ', & + listout = actual) + @assertEqual('first:second:third:fourth', actual) + end subroutine test_shr_string_listDiff_emptyList2 + + @Test + subroutine test_shr_string_listDiff_List2equalsList1() + character(len=list_len) :: actual + + call shr_string_listDiff( & + list1 = 'first:second:third:fourth', & + list2 = 'fourth:second:first:third', & ! same as list1, but different order + listout = actual) + @assertEqual(' ', actual) + end subroutine test_shr_string_listDiff_List2equalsList1 + + ! ------------------------------------------------------------------------ + ! Tests of shr_string_listAddSuffix + ! ------------------------------------------------------------------------ + + @Test + subroutine test_shr_string_listAddSuffix_with_empty_list() + character(len=list_len) :: actual + + call shr_string_listAddSuffix(list=' ', suffix='00', new_list=actual) + @assertEqual(' ', actual) + end subroutine test_shr_string_listAddSuffix_with_empty_list + + @Test + subroutine test_shr_string_listAddSuffix_with_one_element() + character(len=list_len) :: actual + + call shr_string_listAddSuffix(list='first', suffix='00', new_list=actual) + @assertEqual('first00', actual) + end subroutine test_shr_string_listAddSuffix_with_one_element + + @Test + subroutine test_shr_string_listAddSuffix_with_multiple_elements() + character(len=list_len) :: actual, expected + + call shr_string_listAddSuffix(list='first:second:third', suffix='00', new_list=actual) + expected = 'first00:second00:third00' + @assertEqual(expected, actual) + end subroutine test_shr_string_listAddSuffix_with_multiple_elements + + @Test + subroutine test_shr_string_listAddSuffix_with_empty_suffix() + character(len=list_len) :: actual, expected + + call shr_string_listAddSuffix(list='first:second:third', suffix=' ', new_list=actual) + expected = 'first:second:third' + @assertEqual(expected, actual) + end subroutine test_shr_string_listAddSuffix_with_empty_suffix + +end module test_shr_string diff --git a/share/csm_share/test/unit/shr_vmath_test/CMakeLists.txt b/share/csm_share/test/unit/shr_vmath_test/CMakeLists.txt new file mode 100644 index 000000000000..b4eac2ed0a29 --- /dev/null +++ b/share/csm_share/test/unit/shr_vmath_test/CMakeLists.txt @@ -0,0 +1,13 @@ +set(test_sources test_vmath.F90) + +set(sources_needed shr_kind_mod.F90 shr_log_mod.F90 shr_strconvert_mod.F90 + shr_infnan_mod.F90 shr_const_mod.F90 shr_vmath_mod.F90) + +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +add_executable(vmath_test_exe ${test_sources}) + +# Add the actual test. +add_test(vmath vmath_test_exe) + +declare_generated_dependencies(vmath_test_exe "${share_genf90_sources}") diff --git a/share/csm_share/test/unit/shr_vmath_test/test_vmath.F90 b/share/csm_share/test/unit/shr_vmath_test/test_vmath.F90 new file mode 100644 index 000000000000..8278567d0137 --- /dev/null +++ b/share/csm_share/test/unit/shr_vmath_test/test_vmath.F90 @@ -0,0 +1,110 @@ +program test_vmath + +! +! This is a test for the shr_vmath_mod module. +! + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_kind_mod, only: r4 => shr_kind_r4 +use shr_kind_mod, only: i8 => shr_kind_i8 +use shr_kind_mod, only: i4 => shr_kind_i4 +use shr_const_mod, only: pi => shr_const_pi +use shr_vmath_mod + +implicit none +integer, parameter :: vlen = 128 +real(r8) :: ivec(vlen), rvec(vlen), ovec(vlen), nvec(vlen) +real(r8), parameter :: bigval = 1.0E300_r8 +real(r8), parameter :: smallval = 1.0E-300_r8 +real(r8), parameter :: tolerance = 1.0E-15_r8 +integer :: i +call random_number(ivec) ! numbers between 0 and 1 + +ivec = ivec * bigval ! numbers between 0 and 1e308 + +call shr_vmath_sqrt(ivec, rvec, vlen) + +ovec = dsqrt(ivec) +do i=1,vlen + if(abs(rvec(i)-ovec(i)) > tolerance) then + print *,__LINE__,i, ivec(i),rvec(i),ovec(i) + endif +enddo + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_sqrt test failed") + +call shr_vmath_rsqrt(ivec, rvec, vlen) + +ovec = 1.0_r8/ovec + +do i=1,vlen + if(abs((rvec(i)-ovec(i))/ovec(i)) > tolerance) then + print *,__LINE__,i, ivec(i),rvec(i),ovec(i) + endif +enddo + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_rsqrt test failed") + +call random_number(nvec) +nvec = (nvec - 0.5_r8)*bigval + +call shr_vmath_div(ivec, nvec, rvec, vlen) + +ovec = ivec/nvec + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_div test failed") + +call random_number(ivec) +ivec = ivec*1400_r8 - 700_r8 + +call shr_vmath_exp(ivec, rvec, vlen) + +ovec = exp(ivec) +!print *,minval(abs(rvec)),maxval(rvec) + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_exp test failed") + +ivec = ovec +call shr_vmath_log(ivec, rvec, vlen) +ovec = log(ivec) + +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_log test failed") + +call random_number(ivec) +ivec = (ivec-0.5_r8)*2.0_r8*pi +call shr_vmath_sin(ivec, rvec, vlen) +ovec = sin(ivec) +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_sin test failed") + +call shr_vmath_cos(ivec, rvec, vlen) +ovec = cos(ivec) +rvec = (rvec - ovec)/ovec + +call assert(all(abs(rvec) < tolerance),"shr_vmath_cos test failed") + +contains + + subroutine assert(val, msg) + logical, intent(in) :: val + character(len=*), intent(in) :: msg + + if (.not. val) then + print *, msg + stop 1 + end if + + end subroutine assert + +end program test_vmath diff --git a/share/csm_share/test/unit/shr_wv_sat_test/CMakeLists.txt b/share/csm_share/test/unit/shr_wv_sat_test/CMakeLists.txt new file mode 100644 index 000000000000..b6d4eda3f90f --- /dev/null +++ b/share/csm_share/test/unit/shr_wv_sat_test/CMakeLists.txt @@ -0,0 +1,12 @@ +# Local pFUnit files. +set(pf_sources + test_wv_sat.pf test_wv_sat_each_method.pf) + +# Sources to test. +set(sources_needed + shr_kind_mod.F90 shr_const_mod.F90 shr_wv_sat_mod.F90) +extract_sources("${sources_needed}" "${share_sources}" test_sources) + +# Do source preprocessing and add the executable. +create_pFUnit_test(shr_wv_sat_mod shr_wv_sat_mod_exe "${pf_sources}" + "${test_sources}") diff --git a/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat.pf b/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat.pf new file mode 100644 index 000000000000..a50273085864 --- /dev/null +++ b/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat.pf @@ -0,0 +1,256 @@ +module test_wv_sat + +use pfunit_mod + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_const_mod, only: & + tmelt => shr_const_tkfrz, & + h2otrip => shr_const_tktrip, & + mwwv => shr_const_mwwv, & + mwdair => shr_const_mwdair +use shr_wv_sat_mod + +implicit none +public + +real(r8), parameter :: t_transition = 20._r8 +real(r8), parameter :: epsilo = mwwv/mwdair + +contains + +@Before +subroutine setUp() + + character(len=128) :: errstring + + call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) + + if (errstring /= "") then + call throw("Error from shr_wv_sat_init: "//trim(errstring)) + end if + +end subroutine setUp + +@After +subroutine tearDown() + call shr_wv_sat_final() +end subroutine tearDown + +@Test +subroutine invalid_name_produces_invalid_index() + + integer :: idx + + idx = shr_wv_sat_get_scheme_idx("NotARealSaturationSchemeName") + @assertTrue(.not. shr_wv_sat_valid_idx(idx)) + +end subroutine invalid_name_produces_invalid_index + +@Test +subroutine reject_out_of_bounds_transition + + character(len=128) :: errstring + + ! Negative transition ranges are meaningless. + call shr_wv_sat_init(tmelt, h2otrip, -1._r8, epsilo, errstring) + @assertTrue(errstring /= "") + + ! A transition range of 0 is OK. + call shr_wv_sat_init(tmelt, h2otrip, 0._r8, epsilo, errstring) + @assertTrue(errstring == "") + +end subroutine reject_out_of_bounds_transition + +@Test +subroutine qsat_not_greater_than_one() + + ! Even if the SVP is greater the current pressure, the saturation specific + ! humidity returned should be capped at 1. + @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(1.0_r8, 0.5_r8)) + @assertEqual(1.0_r8, shr_wv_sat_svp_to_qsat(2, [1.0_r8, 2.0_r8], [0.5_r8, 0.5_r8])) + +end subroutine qsat_not_greater_than_one + +@Test +subroutine qmmr_not_greater_than_epsilon() + + integer, parameter :: n = 3 + real(r8), parameter :: es(n) = [0.51_r8, 1.0_r8, 1.5_r8] + real(r8), parameter :: p(n) = [1.0_r8, 1.0_r8, 1.0_r8] + + integer :: i + + ! As SVP becomes close to the actual pressure, the mass mixing ratio goes to + ! infinity, so check that we actually cap it at epsilon once the SVP is more + ! than half the total pressure. + do i = 1, 3 + @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(es(i), p(i))) + end do + @assertEqual(epsilo, shr_wv_sat_svp_to_qmmr(n, es, p)) + +end subroutine qmmr_not_greater_than_epsilon + +@Test +subroutine esat_not_greater_than_p() + + real(r8) :: es, qs + real(r8) :: es_vec(1), qs_vec(1) + + ! For the combined routine, we don't allow the SVP to exceed the current + ! pressure. Tested here by simply providing an extremely low pressure. + + ! This is a guard against schemes that "blindly" attempt to reach saturation + ! by evaporating cloud water, no matter what the conditions. At very low + ! pressures this is impossible, so we return a limited value to prevent + ! numerical issues. + + call shr_wv_sat_qsat_liquid(280._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_liquid(1, [280._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + + call shr_wv_sat_qsat_ice(260._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_ice(1, [260._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + + call shr_wv_sat_qsat_mixed(270._r8, 1.e-30_r8, es, qs) + @assertEqual(1.e-30_r8, es) + + call shr_wv_sat_qsat_mixed(1, [270._r8], [1.e-30_r8], es_vec, qs_vec) + @assertEqual([1.e-30_r8], es_vec) + +end subroutine esat_not_greater_than_p + +@Test +subroutine liquid_vapor_table_is_used() + type(ShrWVSatTableSpec) :: liquid_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) + + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) + + table_value = shr_wv_sat_svp_liquid(tmelt+7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine liquid_vapor_table_is_used + +@Test +subroutine liquid_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: liquid_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) + non_table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) + + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + call shr_wv_sat_make_tables(liquid_spec_in=liquid_table_spec) + + table_low_value = shr_wv_sat_svp_liquid(tmelt-50.5_r8) + table_high_value = shr_wv_sat_svp_liquid(tmelt+150.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine liquid_vapor_table_not_extrapolated + +@Test +subroutine ice_vapor_table_is_used() + type(ShrWVSatTableSpec) :: ice_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) + + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) + + table_value = shr_wv_sat_svp_ice(tmelt-7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine ice_vapor_table_is_used + +@Test +subroutine ice_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: ice_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) + non_table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) + + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(ice_spec_in=ice_table_spec) + + table_low_value = shr_wv_sat_svp_ice(tmelt-100.5_r8) + table_high_value = shr_wv_sat_svp_ice(tmelt+5.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine ice_vapor_table_not_extrapolated + +@Test +subroutine mixed_vapor_table_is_used() + type(ShrWVSatTableSpec) :: mixed_table_spec + + real(r8) :: non_table_value + real(r8) :: table_value + + non_table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) + + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) + + table_value = shr_wv_sat_svp_mixed(tmelt-7.5_r8) + + ! We can't really see directly whether the table is used, but we can pick a + ! value that requires interpolation and look for the difference. + @assertFalse(non_table_value == table_value) + +end subroutine mixed_vapor_table_is_used + +@Test +subroutine mixed_vapor_table_not_extrapolated() + type(ShrWVSatTableSpec) :: mixed_table_spec + + real(r8) :: non_table_low_value, non_table_high_value + real(r8) :: table_low_value, table_high_value + + non_table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) + non_table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) + + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(mixed_spec_in=mixed_table_spec) + + table_low_value = shr_wv_sat_svp_mixed(tmelt-100.5_r8) + table_high_value = shr_wv_sat_svp_mixed(tmelt+100.5_r8) + + ! Beyond the table boundaries, the lookup table should not be used, and so we + ! should get the same answer as before specifying any tables. + @assertEqual(non_table_low_value, table_low_value) + @assertEqual(non_table_high_value, table_high_value) + +end subroutine mixed_vapor_table_not_extrapolated + +end module test_wv_sat diff --git a/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat_each_method.pf b/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat_each_method.pf new file mode 100644 index 000000000000..3e2f28ebd87e --- /dev/null +++ b/share/csm_share/test/unit/shr_wv_sat_test/test_wv_sat_each_method.pf @@ -0,0 +1,270 @@ +! This module has a parameterized test list for application to each of the +! individual methods provided by shr_wv_sat_mod. +module test_wv_sat_each_method + +use pfunit_mod + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_const_mod, only: & + tmelt => shr_const_tkfrz, & + h2otrip => shr_const_tktrip, & + mwwv => shr_const_mwwv, & + mwdair => shr_const_mwdair +use shr_wv_sat_mod + +implicit none +public + +real(r8), parameter :: t_transition = 20._r8 + +@TestParameter +type, extends(AbstractTestParameter) :: WVSchemeParameters + character(len=32) :: scheme_name + real(r8) :: relative_tol + logical :: make_table + logical :: use_vector + contains + procedure :: toString +end type WVSchemeParameters + +@TestCase(testParameters={getParameters()}, constructor=new_WVSchemeCase) +type, extends(ParameterizedTestCase) :: WVSchemeCase + character(len=32) :: scheme_name + real(r8) :: relative_tol + logical :: make_table + logical :: use_vector + contains + procedure :: setUp + procedure :: tearDown +end type WVSchemeCase + +contains + +! Simple routines to convert parameters to a test case or a string, +! respectively. + +function new_WVSchemeCase(params) result(test) + type(WVSchemeParameters), intent(in) :: params + type(WVSchemeCase) :: test + + test%scheme_name = params%scheme_name + test%relative_tol = params%relative_tol + test%make_table = params%make_table + test%use_vector = params%use_vector + +end function new_WVSchemeCase + +function toString(this) result(string) + class(WVSchemeParameters), intent(in) :: this + character(:), allocatable :: string + + character(len=80) :: buffer + + write(buffer,*) "(scheme=",this%scheme_name,",table=",this%make_table, & + ",vec=",this%use_vector,")" + + string = trim(buffer) + +end function toString + +! setUp/tearDown to init the module and to actually set the current scheme. +subroutine setUp(this) + + class(WVSchemeCase), intent(inout) :: this + + real(r8), parameter :: epsilo = mwwv/mwdair + + character(len=128) :: errstring + + type(ShrWVSatTableSpec) :: liquid_table_spec, ice_table_spec, mixed_table_spec + + call shr_wv_sat_init(tmelt, h2otrip, t_transition, epsilo, errstring) + + if (errstring /= "") then + call throw("Error from shr_wv_sat_init: "//trim(errstring)) + end if + + @assertTrue(shr_wv_sat_set_default(this%scheme_name)) + + if (this%make_table) then + liquid_table_spec = ShrWVSatTableSpec(151, tmelt-50._r8, 1._r8) + ice_table_spec = ShrWVSatTableSpec(106, tmelt-100._r8, 1._r8) + mixed_table_spec = ShrWVSatTableSpec(201, tmelt-100._r8, 1._r8) + call shr_wv_sat_make_tables(& + liquid_spec_in=liquid_table_spec, & + ice_spec_in=ice_table_spec, & + mixed_spec_in=mixed_table_spec) + end if + +end subroutine setUp + +subroutine tearDown(this) + + class(WVSchemeCase), intent(inout) :: this + + call shr_wv_sat_final() + +end subroutine tearDown + +! List of testable schemes. + +function getParameters() result(params) + type(WVSchemeParameters), allocatable :: params(:) + + params = [ & + WVSchemeParameters("GoffGratch", 0.002_r8, .false., .false.), & + WVSchemeParameters("MurphyKoop", 0.001_r8, .false., .false.), & + WVSchemeParameters("Flatau", 0.003_r8, .false., .false.), & + WVSchemeParameters("Bolton", 0.001_r8, .false., .false.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .true., .false.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .false., .true.), & + WVSchemeParameters("GoffGratch", 0.002_r8, .true., .true.) ] + +end function getParameters + +! Tests for water and ice functions for each scheme. + +@Test +subroutine scheme_has_correct_ice_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_ice(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_ice(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_ice_trip_point + +@Test +subroutine scheme_has_correct_liquid_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_liquid(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_liquid(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_liquid_trip_point + +@Test +subroutine scheme_has_correct_liquid_value(this) + class(WVSchemeCase), intent(inout) :: this + + ! Check a warm value (25 deg C). + if (this%use_vector) then + call assertRelativelyEqual([3169._r8], shr_wv_sat_svp_liquid(1, [tmelt+25._r8]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(3169._r8, shr_wv_sat_svp_liquid(tmelt+25._r8), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_liquid_value + +@Test +subroutine scheme_has_correct_ice_value(this) + class(WVSchemeCase), intent(inout) :: this + + ! Check a cold value (-50 deg C). + if (this%use_vector) then + call assertRelativelyEqual([3.935], shr_wv_sat_svp_ice(1, [tmelt-50._r8]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(3.935, shr_wv_sat_svp_ice(tmelt-50._r8), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_ice_value + +! Tests for the combined water-ice function with transition range. +! Technically, these don't have to be done for each scheme, but it doesn't hurt +! to run them many times, since the tests are very quick. + +@Test +subroutine scheme_has_correct_mixed_trip_point(this) + class(WVSchemeCase), intent(inout) :: this + + if (this%use_vector) then + call assertRelativelyEqual([611.7_r8], shr_wv_sat_svp_mixed(1, [h2otrip]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(611.7_r8, shr_wv_sat_svp_mixed(h2otrip), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_trip_point + +@Test +subroutine scheme_has_correct_mixed_as_ice(this) + class(WVSchemeCase), intent(inout) :: this + + real(r8) :: t_all_ice = tmelt - t_transition - 1._r8 + + real(r8) :: ice_svp + + ice_svp = shr_wv_sat_svp_ice(t_all_ice) + + ! Below the transition range, trans and ice should be equal. + if (this%use_vector) then + call assertRelativelyEqual([ice_svp], shr_wv_sat_svp_mixed(1, [t_all_ice]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(ice_svp, shr_wv_sat_svp_mixed(t_all_ice), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_as_ice + +@Test +subroutine scheme_has_correct_mixed_as_liquid(this) + class(WVSchemeCase), intent(inout) :: this + + real(r8) :: t_all_liquid = tmelt + 1._r8 + + real(r8) :: liquid_svp + + liquid_svp = shr_wv_sat_svp_liquid(t_all_liquid) + + ! Above the transition range, trans and water should be equal. + if (this%use_vector) then + call assertRelativelyEqual([liquid_svp], shr_wv_sat_svp_mixed(1, [t_all_liquid]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(liquid_svp, shr_wv_sat_svp_mixed(t_all_liquid), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_as_liquid + +@Test +subroutine scheme_has_correct_mixed_in_range(this) + class(WVSchemeCase), intent(inout) :: this + + ! Temperature at which we are halfway through the transition range. + real(r8), parameter :: t_half = tmelt - 0.5*t_transition + + real(r8) :: ice_svp, liquid_svp + + ice_svp = shr_wv_sat_svp_ice(t_half) + liquid_svp = shr_wv_sat_svp_liquid(t_half) + + ! Check that transition SVP is the average of the ice and water SVPs. + if (this%use_vector) then + call assertRelativelyEqual([0.5_r8 * (ice_svp+liquid_svp)], & + shr_wv_sat_svp_mixed(1, [t_half]), & + tolerance=this%relative_tol) + else + call assertRelativelyEqual(0.5_r8 * (ice_svp+liquid_svp), & + shr_wv_sat_svp_mixed(t_half), & + tolerance=this%relative_tol) + end if + +end subroutine scheme_has_correct_mixed_in_range + +end module test_wv_sat_each_method diff --git a/share/csm_share/unit_test_stubs/README b/share/csm_share/unit_test_stubs/README new file mode 100644 index 000000000000..45ed9ec72d60 --- /dev/null +++ b/share/csm_share/unit_test_stubs/README @@ -0,0 +1,2 @@ +This directory contains stubs that may be useful for the unit test builds for a +number of components. diff --git a/share/csm_share/unit_test_stubs/pio/CMakeLists.txt b/share/csm_share/unit_test_stubs/pio/CMakeLists.txt new file mode 100644 index 000000000000..415cf1aa7693 --- /dev/null +++ b/share/csm_share/unit_test_stubs/pio/CMakeLists.txt @@ -0,0 +1,7 @@ +# TODO: Figure out how to generate pio.F90 automatically from pio.F90.in + +list(APPEND pio_sources + pio.F90 + ) + +sourcelist_to_parent(pio_sources) \ No newline at end of file diff --git a/share/csm_share/unit_test_stubs/pio/README b/share/csm_share/unit_test_stubs/pio/README new file mode 100644 index 000000000000..0c492e440a61 --- /dev/null +++ b/share/csm_share/unit_test_stubs/pio/README @@ -0,0 +1,2 @@ +This directory contains a stub implementation of (a subset of) PIO. This can be +built in place of the true PIO library in unit tests. diff --git a/share/csm_share/unit_test_stubs/pio/do_genf90 b/share/csm_share/unit_test_stubs/pio/do_genf90 new file mode 100755 index 000000000000..da92f3ed9a9c --- /dev/null +++ b/share/csm_share/unit_test_stubs/pio/do_genf90 @@ -0,0 +1,10 @@ +#!/usr/bin/env bash + +# Run genf90 on all files that need it in this directory + +genf90=../../../../tools/cprnc/genf90/genf90.pl + +for fl in *.in; do + echo $fl + $genf90 $fl > `basename $fl .in` +done diff --git a/share/csm_share/unit_test_stubs/pio/pio.F90 b/share/csm_share/unit_test_stubs/pio/pio.F90 new file mode 100644 index 000000000000..defa959c3fcc --- /dev/null +++ b/share/csm_share/unit_test_stubs/pio/pio.F90 @@ -0,0 +1,4069 @@ +!=================================================== +! DO NOT EDIT THIS FILE, it was generated using ../../../../tools/cprnc/genf90/genf90.pl +! Any changes you make to this file may be lost +!=================================================== +module pio + ! This module provides a stub implementation of a subset of PIO. + ! + ! This can be used when you need the PIO interfaces in order for your unit tests to + ! build, but do not actually need to make use of any of the PIO functionality in your + ! unit tests. + + ! Note that not all PIO functionality is stubbed here. Stubs are written on an + ! as-needed basis, and others can be added here as needed. + + ! Note about organization: variables, functions/subroutines, etc. should be kept in + ! alphabetical order to facilitate finding what you want. Currently, this is roughly + ! true, though is violated for specific routines within a group (e.g., implementations + ! of the initdecomp interface). + + ! NOTE(wjs, 2015-01-12) In some routines here, variables that are declared as + ! intent(out) in the real code are declared intent(inout) here. I am using intent(inout) + ! because I do not want to bother with assigning a value to these, and some compilers + ! complain if you don't assign a value to an intent(out) argument. + + +! uses mpi if available +#ifndef NO_MPIMOD + use mpi, only : MPI_OFFSET_KIND ! _EXTERNAL +#endif + + implicit none + private + +#ifdef NO_MPIMOD + include 'mpif.h' ! _EXTERNAL +#endif + + type, public :: file_desc_t + end type file_desc_t + + type, public :: io_desc_t + end type io_desc_t + + type, public :: iosystem_desc_t + end type iosystem_desc_t + + type, public :: var_desc_t + end type var_desc_t + + integer, parameter, private :: & + i4 = selected_int_kind(6) ,& + i8 = selected_int_kind(13) ,& + r4 = selected_real_kind(6) ,& + r8 = selected_real_kind(13) + + integer, parameter, public :: PIO_64BIT_OFFSET = 0 + integer(i4), parameter, public :: PIO_BCAST_ERROR = 0 + integer, parameter, public :: PIO_CLOBBER = 0 + integer, parameter, public :: PIO_DOUBLE = 0 + integer, parameter, public :: PIO_GLOBAL = 0 + integer, parameter, public :: PIO_INT = 0 + integer(i4), parameter, public :: PIO_INTERNAL_ERROR = 0 + integer, parameter, public :: PIO_iotype_netcdf = 0 + integer, parameter, public :: PIO_iotype_netcdf4c = 0 + integer, parameter, public :: PIO_iotype_netcdf4p = 0 + integer, parameter, public :: PIO_iotype_pnetcdf = 0 + integer, parameter, public :: PIO_NOWRITE = 0 + integer, parameter, public :: pio_offset = MPI_OFFSET_KIND + integer, parameter, public :: pio_offset_kind = pio_offset + integer, parameter, public :: pio_rearr_subset = 0 + integer, parameter, public :: PIO_WRITE = 0 + + public :: PIO_def_dim + public :: PIO_enddef + public :: PIO_FILE_IS_OPEN + public :: pio_inq_dimid + public :: pio_inq_dimlen + public :: pio_set_blocksize + + public :: PIO_closefile +# 77 "pio.F90.in" + interface PIO_closefile + module procedure closefile + end interface PIO_closefile + + public :: PIO_createfile +# 82 "pio.F90.in" + interface PIO_createfile + module procedure createfile + end interface + + public :: pio_def_var +# 87 "pio.F90.in" + interface pio_def_var + module procedure & + def_var_0d, & + def_var_md + end interface + + public :: PIO_finalize +# 94 "pio.F90.in" + interface PIO_finalize + module procedure finalize + end interface + + public :: PIO_freedecomp +# 99 "pio.F90.in" + interface PIO_freedecomp + module procedure freedecomp_ios + module procedure freedecomp_file + end interface + + public :: pio_get_att +# 105 "pio.F90.in" + interface pio_get_att + module procedure get_att_text, get_att_desc_text + module procedure get_att_real, get_att_desc_real + module procedure get_att_double, get_att_desc_double + module procedure get_att_int, get_att_desc_int + ! TYPE real,int,double + module procedure get_att_1d_real, get_att_desc_1d_real + ! TYPE real,int,double + module procedure get_att_1d_int, get_att_desc_1d_int + ! TYPE real,int,double + module procedure get_att_1d_double, get_att_desc_1d_double + end interface + + public :: pio_get_var +# 112 "pio.F90.in" + interface pio_get_var + module procedure get_var_0d_text, get_var_vdesc_0d_text + module procedure get_var_1d_text, get_var_vdesc_1d_text + module procedure get_var_2d_text, get_var_vdesc_2d_text + module procedure get_var_3d_text, get_var_vdesc_3d_text + module procedure get_var_4d_text, get_var_vdesc_4d_text + module procedure get_var_5d_text, get_var_vdesc_5d_text + module procedure get_var_0d_real, get_var_vdesc_0d_real + module procedure get_var_1d_real, get_var_vdesc_1d_real + module procedure get_var_2d_real, get_var_vdesc_2d_real + module procedure get_var_3d_real, get_var_vdesc_3d_real + module procedure get_var_4d_real, get_var_vdesc_4d_real + module procedure get_var_5d_real, get_var_vdesc_5d_real + module procedure get_var_0d_double, get_var_vdesc_0d_double + module procedure get_var_1d_double, get_var_vdesc_1d_double + module procedure get_var_2d_double, get_var_vdesc_2d_double + module procedure get_var_3d_double, get_var_vdesc_3d_double + module procedure get_var_4d_double, get_var_vdesc_4d_double + module procedure get_var_5d_double, get_var_vdesc_5d_double + module procedure get_var_0d_int, get_var_vdesc_0d_int + module procedure get_var_1d_int, get_var_vdesc_1d_int + module procedure get_var_2d_int, get_var_vdesc_2d_int + module procedure get_var_3d_int, get_var_vdesc_3d_int + module procedure get_var_4d_int, get_var_vdesc_4d_int + module procedure get_var_5d_int, get_var_vdesc_5d_int + ! DIMS 1,2,3,4,5 + module procedure get_vara_1d_text, get_vara_vdesc_1d_text + ! DIMS 1,2,3,4,5 + module procedure get_vara_2d_text, get_vara_vdesc_2d_text + ! DIMS 1,2,3,4,5 + module procedure get_vara_3d_text, get_vara_vdesc_3d_text + ! DIMS 1,2,3,4,5 + module procedure get_vara_4d_text, get_vara_vdesc_4d_text + ! DIMS 1,2,3,4,5 + module procedure get_vara_5d_text, get_vara_vdesc_5d_text + ! DIMS 1,2,3,4,5 + module procedure get_vara_1d_real, get_vara_vdesc_1d_real + ! DIMS 1,2,3,4,5 + module procedure get_vara_2d_real, get_vara_vdesc_2d_real + ! DIMS 1,2,3,4,5 + module procedure get_vara_3d_real, get_vara_vdesc_3d_real + ! DIMS 1,2,3,4,5 + module procedure get_vara_4d_real, get_vara_vdesc_4d_real + ! DIMS 1,2,3,4,5 + module procedure get_vara_5d_real, get_vara_vdesc_5d_real + ! DIMS 1,2,3,4,5 + module procedure get_vara_1d_double, get_vara_vdesc_1d_double + ! DIMS 1,2,3,4,5 + module procedure get_vara_2d_double, get_vara_vdesc_2d_double + ! DIMS 1,2,3,4,5 + module procedure get_vara_3d_double, get_vara_vdesc_3d_double + ! DIMS 1,2,3,4,5 + module procedure get_vara_4d_double, get_vara_vdesc_4d_double + ! DIMS 1,2,3,4,5 + module procedure get_vara_5d_double, get_vara_vdesc_5d_double + ! DIMS 1,2,3,4,5 + module procedure get_vara_1d_int, get_vara_vdesc_1d_int + ! DIMS 1,2,3,4,5 + module procedure get_vara_2d_int, get_vara_vdesc_2d_int + ! DIMS 1,2,3,4,5 + module procedure get_vara_3d_int, get_vara_vdesc_3d_int + ! DIMS 1,2,3,4,5 + module procedure get_vara_4d_int, get_vara_vdesc_4d_int + ! DIMS 1,2,3,4,5 + module procedure get_vara_5d_int, get_vara_vdesc_5d_int + module procedure get_var1_text, get_var1_vdesc_text + module procedure get_var1_real, get_var1_vdesc_real + module procedure get_var1_double, get_var1_vdesc_double + module procedure get_var1_int, get_var1_vdesc_int + end interface + + public :: PIO_init +# 120 "pio.F90.in" + interface PIO_init + module procedure init_intracom + module procedure init_intercom + end interface + + public :: PIO_initdecomp +# 126 "pio.F90.in" + interface PIO_initdecomp + module procedure PIO_initdecomp_dof_i4 ! previous name: initdecomop_1dof_nf_box + module procedure PIO_initdecomp_dof_i8 ! previous name: initdecomop_1dof_nf_box + module procedure PIO_initdecomp_dof_i8_vdc + module procedure initdecomp_1dof_nf_i4 + module procedure initdecomp_1dof_nf_i8 + module procedure initdecomp_1dof_bin_i4 + module procedure initdecomp_1dof_bin_i8 + module procedure initdecomp_2dof_nf_i4 + module procedure initdecomp_2dof_nf_i8 + module procedure initdecomp_2dof_bin_i4 + module procedure initdecomp_2dof_bin_i8 + module procedure PIO_initdecomp_bc + module procedure PIO_initdecomp_dof_dof + end interface + + public :: pio_inq_varid +# 143 "pio.F90.in" + interface pio_inq_varid + module procedure inq_varid_vid, & + inq_varid_vardesc + end interface pio_inq_varid + + public :: PIO_openfile +# 149 "pio.F90.in" + interface PIO_openfile + module procedure PIO_openfile + end interface + + public :: PIO_put_att +# 154 "pio.F90.in" + interface PIO_put_att + module procedure put_att_text, put_att_desc_text + module procedure put_att_real, put_att_desc_real + module procedure put_att_double, put_att_desc_double + module procedure put_att_int, put_att_desc_int + ! TYPE real,int,double + module procedure put_att_1d_real, put_att_desc_1d_real + ! TYPE real,int,double + module procedure put_att_1d_int, put_att_desc_1d_int + ! TYPE real,int,double + module procedure put_att_1d_double, put_att_desc_1d_double + end interface + + public :: pio_put_var +# 161 "pio.F90.in" + interface pio_put_var + ! DIMS 0,1,2,3,4,5 + module procedure put_var_0d_text, put_var_vdesc_0d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_1d_text, put_var_vdesc_1d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_2d_text, put_var_vdesc_2d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_3d_text, put_var_vdesc_3d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_4d_text, put_var_vdesc_4d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_5d_text, put_var_vdesc_5d_text + ! DIMS 0,1,2,3,4,5 + module procedure put_var_0d_real, put_var_vdesc_0d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_1d_real, put_var_vdesc_1d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_2d_real, put_var_vdesc_2d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_3d_real, put_var_vdesc_3d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_4d_real, put_var_vdesc_4d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_5d_real, put_var_vdesc_5d_real + ! DIMS 0,1,2,3,4,5 + module procedure put_var_0d_double, put_var_vdesc_0d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_1d_double, put_var_vdesc_1d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_2d_double, put_var_vdesc_2d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_3d_double, put_var_vdesc_3d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_4d_double, put_var_vdesc_4d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_5d_double, put_var_vdesc_5d_double + ! DIMS 0,1,2,3,4,5 + module procedure put_var_0d_int, put_var_vdesc_0d_int + ! DIMS 0,1,2,3,4,5 + module procedure put_var_1d_int, put_var_vdesc_1d_int + ! DIMS 0,1,2,3,4,5 + module procedure put_var_2d_int, put_var_vdesc_2d_int + ! DIMS 0,1,2,3,4,5 + module procedure put_var_3d_int, put_var_vdesc_3d_int + ! DIMS 0,1,2,3,4,5 + module procedure put_var_4d_int, put_var_vdesc_4d_int + ! DIMS 0,1,2,3,4,5 + module procedure put_var_5d_int, put_var_vdesc_5d_int + ! DIMS 1,2,3,4,5 + module procedure put_vara_1d_text, put_vara_vdesc_1d_text + ! DIMS 1,2,3,4,5 + module procedure put_vara_2d_text, put_vara_vdesc_2d_text + ! DIMS 1,2,3,4,5 + module procedure put_vara_3d_text, put_vara_vdesc_3d_text + ! DIMS 1,2,3,4,5 + module procedure put_vara_4d_text, put_vara_vdesc_4d_text + ! DIMS 1,2,3,4,5 + module procedure put_vara_5d_text, put_vara_vdesc_5d_text + ! DIMS 1,2,3,4,5 + module procedure put_vara_1d_real, put_vara_vdesc_1d_real + ! DIMS 1,2,3,4,5 + module procedure put_vara_2d_real, put_vara_vdesc_2d_real + ! DIMS 1,2,3,4,5 + module procedure put_vara_3d_real, put_vara_vdesc_3d_real + ! DIMS 1,2,3,4,5 + module procedure put_vara_4d_real, put_vara_vdesc_4d_real + ! DIMS 1,2,3,4,5 + module procedure put_vara_5d_real, put_vara_vdesc_5d_real + ! DIMS 1,2,3,4,5 + module procedure put_vara_1d_double, put_vara_vdesc_1d_double + ! DIMS 1,2,3,4,5 + module procedure put_vara_2d_double, put_vara_vdesc_2d_double + ! DIMS 1,2,3,4,5 + module procedure put_vara_3d_double, put_vara_vdesc_3d_double + ! DIMS 1,2,3,4,5 + module procedure put_vara_4d_double, put_vara_vdesc_4d_double + ! DIMS 1,2,3,4,5 + module procedure put_vara_5d_double, put_vara_vdesc_5d_double + ! DIMS 1,2,3,4,5 + module procedure put_vara_1d_int, put_vara_vdesc_1d_int + ! DIMS 1,2,3,4,5 + module procedure put_vara_2d_int, put_vara_vdesc_2d_int + ! DIMS 1,2,3,4,5 + module procedure put_vara_3d_int, put_vara_vdesc_3d_int + ! DIMS 1,2,3,4,5 + module procedure put_vara_4d_int, put_vara_vdesc_4d_int + ! DIMS 1,2,3,4,5 + module procedure put_vara_5d_int, put_vara_vdesc_5d_int + module procedure put_var1_text, put_var1_vdesc_text + module procedure put_var1_real, put_var1_vdesc_real + module procedure put_var1_double, put_var1_vdesc_double + module procedure put_var1_int, put_var1_vdesc_int + end interface + + public :: PIO_read_darray +# 170 "pio.F90.in" + interface PIO_read_darray +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_1d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_2d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_3d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_4d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_5d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_6d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_7d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_1d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_2d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_3d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_4d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_5d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_6d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_7d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_1d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_2d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_3d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_4d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_5d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_6d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_7d_double + end interface + + public :: pio_set_buffer_size_limit +# 177 "pio.F90.in" + interface pio_set_buffer_size_limit + module procedure pio_set_buffer_size_limit_i4 + module procedure pio_set_buffer_size_limit_i8 + end interface + + public :: PIO_setdebuglevel +# 183 "pio.F90.in" + interface PIO_setdebuglevel + module procedure setdebuglevel + end interface PIO_setdebuglevel + + public :: PIO_seterrorhandling +# 188 "pio.F90.in" + interface PIO_seterrorhandling + module procedure seterrorhandlingf + module procedure seterrorhandlingi + end interface + + public :: PIO_write_darray +# 194 "pio.F90.in" + interface PIO_write_darray +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_1d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_2d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_3d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_4d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_5d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_6d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_7d_real +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_1d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_2d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_3d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_4d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_5d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_6d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_7d_int +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_1d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_2d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_3d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_4d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_5d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_6d_double +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_7d_double + end interface + +# 200 "pio.F90.in" +contains + +# 202 "pio.F90.in" + subroutine closefile(file) + type (file_desc_t),intent(inout) :: file +# 204 "pio.F90.in" + end subroutine closefile + +# 206 "pio.F90.in" + integer function createfile(iosystem, file,iotype, fname, amode_in) result(ierr) + type (iosystem_desc_t), intent(inout), target :: iosystem + type (file_desc_t), intent(inout) :: file + integer, intent(in) :: iotype + character(len=*), intent(in) :: fname + integer, optional, intent(in) :: amode_in + + ierr = 0 +# 214 "pio.F90.in" + end function createfile + +# 216 "pio.F90.in" + integer function def_var_0d(File,name,type,vardesc) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(in) :: type + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 +# 224 "pio.F90.in" + end function def_var_0d + +# 226 "pio.F90.in" + integer function def_var_md(File,name,type,dimids,vardesc) result(ierr) + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(in) :: type + integer, intent(in) :: dimids(:) + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 +# 234 "pio.F90.in" + end function def_var_md + +# 236 "pio.F90.in" + subroutine finalize(iosystem,ierr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(out) :: ierr + + ierr = 0 +# 241 "pio.F90.in" + end subroutine finalize + +# 243 "pio.F90.in" + subroutine freedecomp_ios(ios,iodesc) + type (iosystem_desc_t) :: ios + type (io_desc_t) :: iodesc +# 246 "pio.F90.in" + end subroutine freedecomp_ios + +# 248 "pio.F90.in" + subroutine freedecomp_file(file,iodesc) + type (file_desc_t) :: file + type (io_desc_t) :: iodesc +# 251 "pio.F90.in" + end subroutine freedecomp_file + +# 253 "pio.F90.in" + integer function get_att_desc_text (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + character(len=*), intent(inout) :: value + + ierr = 0 +# 260 "pio.F90.in" + end function get_att_desc_text +# 253 "pio.F90.in" + integer function get_att_desc_real (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r4), intent(inout) :: value + + ierr = 0 +# 260 "pio.F90.in" + end function get_att_desc_real +# 253 "pio.F90.in" + integer function get_att_desc_double (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r8), intent(inout) :: value + + ierr = 0 +# 260 "pio.F90.in" + end function get_att_desc_double +# 253 "pio.F90.in" + integer function get_att_desc_int (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + integer(i4), intent(inout) :: value + + ierr = 0 +# 260 "pio.F90.in" + end function get_att_desc_int + +! TYPE real,int,double +# 263 "pio.F90.in" + integer function get_att_desc_1d_real (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r4), intent(inout) :: value(:) + + ierr = 0 +# 270 "pio.F90.in" + end function get_att_desc_1d_real +! TYPE real,int,double +# 263 "pio.F90.in" + integer function get_att_desc_1d_int (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + integer(i4), intent(inout) :: value(:) + + ierr = 0 +# 270 "pio.F90.in" + end function get_att_desc_1d_int +! TYPE real,int,double +# 263 "pio.F90.in" + integer function get_att_desc_1d_double (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r8), intent(inout) :: value(:) + + ierr = 0 +# 270 "pio.F90.in" + end function get_att_desc_1d_double + +# 272 "pio.F90.in" + integer function get_att_text (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + character(len=*), intent(inout) :: value + + ierr = 0 +# 279 "pio.F90.in" + end function get_att_text +# 272 "pio.F90.in" + integer function get_att_real (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + real(r4), intent(inout) :: value + + ierr = 0 +# 279 "pio.F90.in" + end function get_att_real +# 272 "pio.F90.in" + integer function get_att_double (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + real(r8), intent(inout) :: value + + ierr = 0 +# 279 "pio.F90.in" + end function get_att_double +# 272 "pio.F90.in" + integer function get_att_int (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + integer(i4), intent(inout) :: value + + ierr = 0 +# 279 "pio.F90.in" + end function get_att_int + +! TYPE real,int,double +# 282 "pio.F90.in" + integer function get_att_1d_real (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + real(r4), intent(inout) :: value(:) + + ierr = 0 +# 289 "pio.F90.in" + end function get_att_1d_real +! TYPE real,int,double +# 282 "pio.F90.in" + integer function get_att_1d_int (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + integer(i4), intent(inout) :: value(:) + + ierr = 0 +# 289 "pio.F90.in" + end function get_att_1d_int +! TYPE real,int,double +# 282 "pio.F90.in" + integer function get_att_1d_double (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + real(r8), intent(inout) :: value(:) + + ierr = 0 +# 289 "pio.F90.in" + end function get_att_1d_double + +# 291 "pio.F90.in" + integer function get_var1_text (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, index(:) + character(len=*), intent(inout) :: ival + + ierr = 0 +# 297 "pio.F90.in" + end function get_var1_text +# 291 "pio.F90.in" + integer function get_var1_real (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, index(:) + real(r4), intent(inout) :: ival + + ierr = 0 +# 297 "pio.F90.in" + end function get_var1_real +# 291 "pio.F90.in" + integer function get_var1_double (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, index(:) + real(r8), intent(inout) :: ival + + ierr = 0 +# 297 "pio.F90.in" + end function get_var1_double +# 291 "pio.F90.in" + integer function get_var1_int (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, index(:) + integer(i4), intent(inout) :: ival + + ierr = 0 +# 297 "pio.F90.in" + end function get_var1_int + +# 299 "pio.F90.in" + integer function get_var1_vdesc_text (File,vardesc, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: index(:) + character(len=*), intent(inout) :: ival + + ierr = 0 +# 306 "pio.F90.in" + end function get_var1_vdesc_text +# 299 "pio.F90.in" + integer function get_var1_vdesc_real (File,vardesc, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: index(:) + real(r4), intent(inout) :: ival + + ierr = 0 +# 306 "pio.F90.in" + end function get_var1_vdesc_real +# 299 "pio.F90.in" + integer function get_var1_vdesc_double (File,vardesc, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: index(:) + real(r8), intent(inout) :: ival + + ierr = 0 +# 306 "pio.F90.in" + end function get_var1_vdesc_double +# 299 "pio.F90.in" + integer function get_var1_vdesc_int (File,vardesc, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: index(:) + integer(i4), intent(inout) :: ival + + ierr = 0 +# 306 "pio.F90.in" + end function get_var1_vdesc_int + +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_1d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(inout) :: ival(:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_1d_text +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_2d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(inout) :: ival(:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_2d_text +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_3d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_3d_text +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_4d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_4d_text +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_5d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_5d_text +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_1d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(inout) :: ival(:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_1d_real +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_2d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(inout) :: ival(:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_2d_real +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_3d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_3d_real +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_4d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_4d_real +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_5d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_5d_real +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_1d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(inout) :: ival(:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_1d_double +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_2d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(inout) :: ival(:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_2d_double +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_3d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_3d_double +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_4d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_4d_double +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_5d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_5d_double +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_1d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(inout) :: ival(:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_1d_int +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_2d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(inout) :: ival(:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_2d_int +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_3d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_3d_int +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_4d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_4d_int +! DIMS 1,2,3,4,5 +# 309 "pio.F90.in" + integer function get_vara_5d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 315 "pio.F90.in" + end function get_vara_5d_int + +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_1d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(inout) :: ival(:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_1d_text +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_2d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(inout) :: ival(:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_2d_text +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_3d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_3d_text +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_4d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_4d_text +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_5d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_5d_text +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_1d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(inout) :: ival(:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_1d_real +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_2d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(inout) :: ival(:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_2d_real +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_3d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_3d_real +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_4d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_4d_real +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_5d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_5d_real +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_1d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(inout) :: ival(:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_1d_double +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_2d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(inout) :: ival(:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_2d_double +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_3d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_3d_double +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_4d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_4d_double +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_5d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_5d_double +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_1d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(inout) :: ival(:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_1d_int +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_2d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(inout) :: ival(:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_2d_int +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_3d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_3d_int +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_4d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_4d_int +! DIMS 1,2,3,4,5 +# 318 "pio.F90.in" + integer function get_vara_vdesc_5d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 325 "pio.F90.in" + end function get_vara_vdesc_5d_int + +# 327 "pio.F90.in" + integer function get_var_0d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_0d_text +# 327 "pio.F90.in" + integer function get_var_1d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival(:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_1d_text +# 327 "pio.F90.in" + integer function get_var_2d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival(:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_2d_text +# 327 "pio.F90.in" + integer function get_var_3d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_3d_text +# 327 "pio.F90.in" + integer function get_var_4d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_4d_text +# 327 "pio.F90.in" + integer function get_var_5d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + character(len=*), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_5d_text +# 327 "pio.F90.in" + integer function get_var_0d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_0d_real +# 327 "pio.F90.in" + integer function get_var_1d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival(:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_1d_real +# 327 "pio.F90.in" + integer function get_var_2d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival(:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_2d_real +# 327 "pio.F90.in" + integer function get_var_3d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_3d_real +# 327 "pio.F90.in" + integer function get_var_4d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_4d_real +# 327 "pio.F90.in" + integer function get_var_5d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_5d_real +# 327 "pio.F90.in" + integer function get_var_0d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_0d_double +# 327 "pio.F90.in" + integer function get_var_1d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival(:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_1d_double +# 327 "pio.F90.in" + integer function get_var_2d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival(:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_2d_double +# 327 "pio.F90.in" + integer function get_var_3d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_3d_double +# 327 "pio.F90.in" + integer function get_var_4d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_4d_double +# 327 "pio.F90.in" + integer function get_var_5d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + real(r8), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_5d_double +# 327 "pio.F90.in" + integer function get_var_0d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_0d_int +# 327 "pio.F90.in" + integer function get_var_1d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival(:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_1d_int +# 327 "pio.F90.in" + integer function get_var_2d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival(:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_2d_int +# 327 "pio.F90.in" + integer function get_var_3d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_3d_int +# 327 "pio.F90.in" + integer function get_var_4d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_4d_int +# 327 "pio.F90.in" + integer function get_var_5d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + integer(i4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 333 "pio.F90.in" + end function get_var_5d_int + +# 335 "pio.F90.in" + integer function get_var_vdesc_0d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_0d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_1d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival(:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_1d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_2d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival(:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_2d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_3d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_3d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_4d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_4d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_5d_text (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + character(len=*), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_5d_text +# 335 "pio.F90.in" + integer function get_var_vdesc_0d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_0d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_1d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival(:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_1d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_2d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival(:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_2d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_3d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_3d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_4d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_4d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_5d_real (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_5d_real +# 335 "pio.F90.in" + integer function get_var_vdesc_0d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_0d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_1d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival(:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_1d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_2d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival(:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_2d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_3d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_3d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_4d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_4d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_5d_double (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + real(r8), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_5d_double +# 335 "pio.F90.in" + integer function get_var_vdesc_0d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_0d_int +# 335 "pio.F90.in" + integer function get_var_vdesc_1d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival(:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_1d_int +# 335 "pio.F90.in" + integer function get_var_vdesc_2d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival(:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_2d_int +# 335 "pio.F90.in" + integer function get_var_vdesc_3d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival(:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_3d_int +# 335 "pio.F90.in" + integer function get_var_vdesc_4d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival(:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_4d_int +# 335 "pio.F90.in" + integer function get_var_vdesc_5d_int (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer(i4), intent(inout) :: ival(:,:,:,:,:) + + ierr = 0 +# 341 "pio.F90.in" + end function get_var_vdesc_5d_int + +# 343 "pio.F90.in" + subroutine init_intracom(comp_rank, comp_comm, num_iotasks, num_aggregator, stride, rearr, iosystem,base) + integer(i4), intent(in) :: comp_rank + integer(i4), intent(in) :: comp_comm + integer(i4), intent(in) :: num_iotasks + integer(i4), intent(in) :: num_aggregator + integer(i4), intent(in) :: stride + integer(i4), intent(in) :: rearr + type (iosystem_desc_t), intent(inout) :: iosystem ! io descriptor to initalize + + integer(i4), intent(in),optional :: base +# 353 "pio.F90.in" + end subroutine init_intracom + +# 355 "pio.F90.in" + subroutine init_intercom(component_count, peer_comm, comp_comms, io_comm, iosystem) + integer, intent(in) :: component_count + integer, intent(in) :: peer_comm + integer, intent(in) :: comp_comms(component_count) ! The compute communicator + integer, intent(in) :: io_comm ! The io communicator + + type (iosystem_desc_t), intent(inout) :: iosystem(component_count) ! io descriptor to initalize +# 362 "pio.F90.in" + end subroutine init_intercom + +# 364 "pio.F90.in" + subroutine PIO_initdecomp_bc(iosystem,basepiotype,dims,compstart,compcount,iodesc,iostart,iocount) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (kind=PIO_OFFSET) :: compstart(:) + integer (kind=PIO_OFFSET) :: compcount(:) + type (IO_desc_t), intent(inout) :: iodesc + integer (kind=PIO_OFFSET),optional :: iostart(:) + integer (kind=PIO_OFFSET),optional :: iocount(:) +# 373 "pio.F90.in" + end subroutine PIO_initdecomp_bc + +# 375 "pio.F90.in" + subroutine PIO_initdecomp_dof_dof(iosystem,basepiotype,dims,compdof,iodesc,iodof) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer(i4), intent(in) :: compdof(:) + type (IO_desc_t), intent(inout) :: iodesc + integer(i4), intent(in) :: iodof(:) +# 382 "pio.F90.in" + end subroutine PIO_initdecomp_dof_dof + +# 384 "pio.F90.in" + subroutine initdecomp_2dof_bin_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) !> global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) !> global degrees of freedom for io decomposition + integer (i4), intent(in) :: iodofw(:) !> global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc +# 393 "pio.F90.in" + end subroutine initdecomp_2dof_bin_i4 + +# 395 "pio.F90.in" + subroutine initdecomp_2dof_bin_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) !> global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodofr(:) !> global degrees of freedom for io decomposition + integer (kind=pio_offset), intent(in) :: iodofw(:) !> global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc +# 404 "pio.F90.in" + end subroutine initdecomp_2dof_bin_i8 + +# 406 "pio.F90.in" + subroutine initdecomp_1dof_bin_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer(i4), intent(in) :: lenblocks + integer(kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer(kind=pio_offset), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc +# 414 "pio.F90.in" + end subroutine initdecomp_1dof_bin_i8 + +# 416 "pio.F90.in" + subroutine initdecomp_1dof_bin_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc +# 424 "pio.F90.in" + end subroutine initdecomp_1dof_bin_i4 + +# 426 "pio.F90.in" + subroutine initdecomp_2dof_nf_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + integer (i4), intent(in) :: iodofw(:) ! global degrees of freedom for io decomposition + + type (io_desc_t), intent(inout) :: iodesc + + integer(kind=PIO_offset), intent(in) :: start(:), count(:) +# 438 "pio.F90.in" + end subroutine initdecomp_2dof_nf_i4 + +# 440 "pio.F90.in" + subroutine initdecomp_2dof_nf_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + integer (kind=pio_offset), intent(in) :: iodofw(:) ! global degrees of freedom for io decomposition + + type (io_desc_t), intent(inout) :: iodesc + + integer(kind=PIO_offset), intent(in) :: start(:), count(:) +# 452 "pio.F90.in" + end subroutine initdecomp_2dof_nf_i8 + +# 454 "pio.F90.in" + subroutine initdecomp_1dof_nf_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodof,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodof(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + integer :: piotype + integer(kind=PIO_offset), intent(in) :: start(:), count(:) +# 464 "pio.F90.in" + end subroutine initdecomp_1dof_nf_i4 + +# 466 "pio.F90.in" + subroutine initdecomp_1dof_nf_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodof,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodof(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + integer :: piotype + integer(kind=PIO_offset), intent(in) :: start(:), count(:) +# 476 "pio.F90.in" + end subroutine initdecomp_1dof_nf_i8 + +# 478 "pio.F90.in" + subroutine PIO_initdecomp_dof_i4(iosystem,basepiotype,dims,compdof, iodesc, iostart, iocount, num_ts, bsize, rearr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=PIO_offset), optional :: iostart(:), iocount(:) + type (io_desc_t), intent(inout) :: iodesc + integer(i4), intent(in) :: dims(:) + integer, intent(in), optional :: rearr + !vdf optionals + integer(i4), intent(in), optional:: num_ts, bsize(3) +# 488 "pio.F90.in" + end subroutine PIO_initdecomp_dof_i4 + +# 490 "pio.F90.in" + subroutine PIO_initdecomp_dof_i8(iosystem,basepiotype,dims,compdof, iodesc, iostart, iocount, rearr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=PIO_offset), optional :: iostart(:), iocount(:) + type (io_desc_t), intent(inout) :: iodesc + integer, intent(in), optional :: rearr +# 498 "pio.F90.in" + end subroutine PIO_initdecomp_dof_i8 + +# 500 "pio.F90.in" + subroutine PIO_initdecomp_dof_i8_vdc(iosystem,dims,compdof, iodesc, num_ts, bsize) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: dims(:) + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + + type (io_desc_t), intent(inout) :: iodesc + !vdc args + integer(i4), intent(in) :: num_ts + integer(i4), intent(in), optional:: bsize(3) +# 509 "pio.F90.in" + end subroutine PIO_initdecomp_dof_i8_vdc + +# 511 "pio.F90.in" + integer function inq_varid_vardesc(File,name,vardesc) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 +# 518 "pio.F90.in" + end function inq_varid_vardesc + +# 520 "pio.F90.in" + integer function inq_varid_vid(File,name,varid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer(i4), intent(out) :: varid + + varid = 0 + ierr = 0 +# 528 "pio.F90.in" + end function inq_varid_vid + + +# 531 "pio.F90.in" + integer function PIO_def_dim(File,name,len,dimid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer(i4), intent(in) :: len + integer(i4), intent(out) :: dimid + + dimid = 0 + ierr = 0 +# 540 "pio.F90.in" + end function PIO_def_dim + +# 542 "pio.F90.in" + integer function PIO_enddef(File) result(ierr) + type (File_desc_t), intent(inout) :: File + + ierr = 0 +# 546 "pio.F90.in" + end function PIO_enddef + +# 548 "pio.F90.in" + logical function PIO_FILE_IS_OPEN(File) + type(file_desc_t), intent(in) :: file + + PIO_FILE_IS_OPEN = .false. +# 552 "pio.F90.in" + end function PIO_FILE_IS_OPEN + +# 554 "pio.F90.in" + integer function pio_inq_dimid(File,name,dimid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(out) :: dimid !dimension ID + + dimid = 0 + ierr = 0 +# 562 "pio.F90.in" + end function pio_inq_dimid + +# 564 "pio.F90.in" + integer function pio_inq_dimlen(File,dimid,dimlen) result(ierr) + + type (File_desc_t), intent(in) :: File + integer(i4) , intent(in) :: dimid + integer(i4) , intent(out) :: dimlen !dimension name + + dimlen = 0 + ierr = 0 +# 572 "pio.F90.in" + end function pio_inq_dimlen + +# 574 "pio.F90.in" + integer function PIO_openfile(iosystem, file, iotype, fname,mode, CheckMPI) result(ierr) + type (iosystem_desc_t), intent(inout), target :: iosystem + type (file_desc_t), intent(out) :: file + integer, intent(in) :: iotype + character(len=*), intent(in) :: fname + integer, optional, intent(in) :: mode + logical, optional, intent(in) :: CheckMPI + + ierr = 0 +# 583 "pio.F90.in" + end function PIO_openfile + +# 585 "pio.F90.in" + subroutine pio_set_blocksize(newsize) + integer, intent(in) :: newsize +# 587 "pio.F90.in" + end subroutine pio_set_blocksize + +# 589 "pio.F90.in" + subroutine pio_set_buffer_size_limit_i4(limit) + integer, intent(in) :: limit +# 591 "pio.F90.in" + end subroutine pio_set_buffer_size_limit_i4 + +# 593 "pio.F90.in" + subroutine pio_set_buffer_size_limit_i8(limit) + integer(pio_offset), intent(in) :: limit +# 595 "pio.F90.in" + end subroutine pio_set_buffer_size_limit_i8 + +# 597 "pio.F90.in" + integer function put_att_text (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + + ierr = 0 +# 604 "pio.F90.in" + end function put_att_text +# 597 "pio.F90.in" + integer function put_att_real (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + real(r4), intent(in) :: value + + ierr = 0 +# 604 "pio.F90.in" + end function put_att_real +# 597 "pio.F90.in" + integer function put_att_double (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + real(r8), intent(in) :: value + + ierr = 0 +# 604 "pio.F90.in" + end function put_att_double +# 597 "pio.F90.in" + integer function put_att_int (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + integer(i4), intent(in) :: value + + ierr = 0 +# 604 "pio.F90.in" + end function put_att_int + +! TYPE real,double,int +# 607 "pio.F90.in" + integer function put_att_1d_real (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + real(r4), intent(in) :: value(:) + + ierr = 0 +# 614 "pio.F90.in" + end function put_att_1d_real +! TYPE real,double,int +# 607 "pio.F90.in" + integer function put_att_1d_double (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + real(r8), intent(in) :: value(:) + + ierr = 0 +# 614 "pio.F90.in" + end function put_att_1d_double +! TYPE real,double,int +# 607 "pio.F90.in" + integer function put_att_1d_int (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + integer(i4), intent(in) :: value(:) + + ierr = 0 +# 614 "pio.F90.in" + end function put_att_1d_int + +# 616 "pio.F90.in" + integer function put_att_desc_text (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + character(len=*), intent(in) :: value + + ierr = 0 +# 623 "pio.F90.in" + end function put_att_desc_text +# 616 "pio.F90.in" + integer function put_att_desc_real (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r4), intent(in) :: value + + ierr = 0 +# 623 "pio.F90.in" + end function put_att_desc_real +# 616 "pio.F90.in" + integer function put_att_desc_double (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r8), intent(in) :: value + + ierr = 0 +# 623 "pio.F90.in" + end function put_att_desc_double +# 616 "pio.F90.in" + integer function put_att_desc_int (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + integer(i4), intent(in) :: value + + ierr = 0 +# 623 "pio.F90.in" + end function put_att_desc_int + +! TYPE real,int,double +# 626 "pio.F90.in" + integer function put_att_desc_1d_real (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r4), intent(in) :: value(:) + + ierr = 0 +# 633 "pio.F90.in" + end function put_att_desc_1d_real +! TYPE real,int,double +# 626 "pio.F90.in" + integer function put_att_desc_1d_int (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + integer(i4), intent(in) :: value(:) + + ierr = 0 +# 633 "pio.F90.in" + end function put_att_desc_1d_int +! TYPE real,int,double +# 626 "pio.F90.in" + integer function put_att_desc_1d_double (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + real(r8), intent(in) :: value(:) + + ierr = 0 +# 633 "pio.F90.in" + end function put_att_desc_1d_double + +# 635 "pio.F90.in" + integer function put_var1_text (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + character(len=*), intent(in) :: ival + + ierr = 0 +# 641 "pio.F90.in" + end function put_var1_text + +! TYPE int,real,double +# 644 "pio.F90.in" + integer function put_var1_int (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + integer(i4), intent(in) :: ival + + ierr = 0 +# 650 "pio.F90.in" + end function put_var1_int +! TYPE int,real,double +# 644 "pio.F90.in" + integer function put_var1_real (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + real(r4), intent(in) :: ival + + ierr = 0 +# 650 "pio.F90.in" + end function put_var1_real +! TYPE int,real,double +# 644 "pio.F90.in" + integer function put_var1_double (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + real(r8), intent(in) :: ival + + ierr = 0 +# 650 "pio.F90.in" + end function put_var1_double + +# 652 "pio.F90.in" + integer function put_var1_vdesc_text (File,vardesc, start, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:) + character(len=*), intent(in) :: ival + + ierr = 0 +# 659 "pio.F90.in" + end function put_var1_vdesc_text +# 652 "pio.F90.in" + integer function put_var1_vdesc_real (File,vardesc, start, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:) + real(r4), intent(in) :: ival + + ierr = 0 +# 659 "pio.F90.in" + end function put_var1_vdesc_real +# 652 "pio.F90.in" + integer function put_var1_vdesc_double (File,vardesc, start, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:) + real(r8), intent(in) :: ival + + ierr = 0 +# 659 "pio.F90.in" + end function put_var1_vdesc_double +# 652 "pio.F90.in" + integer function put_var1_vdesc_int (File,vardesc, start, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:) + integer(i4), intent(in) :: ival + + ierr = 0 +# 659 "pio.F90.in" + end function put_var1_vdesc_int + +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_0d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_0d_text +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_1d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival(:) + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_1d_text +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_2d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival(:,:) + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_2d_text +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_3d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival(:,:,:) + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_3d_text +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_4d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_4d_text +! DIMS 0,1,2,3,4,5 +! TYPE text +# 663 "pio.F90.in" + integer function put_var_5d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 669 "pio.F90.in" + end function put_var_5d_text + +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_1d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival(:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_1d_int +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_2d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival(:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_2d_int +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_3d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_3d_int +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_4d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_4d_int +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_5d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_5d_int +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_1d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival(:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_1d_real +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_2d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival(:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_2d_real +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_3d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_3d_real +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_4d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_4d_real +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_5d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_5d_real +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_1d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival(:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_1d_double +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_2d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival(:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_2d_double +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_3d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival(:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_3d_double +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_4d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_4d_double +! DIMS 1,2,3,4,5 +! TYPE int,real,double +# 673 "pio.F90.in" + integer function put_var_5d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 679 "pio.F90.in" + end function put_var_5d_double + +! TYPE int,real,double +# 682 "pio.F90.in" + integer function put_var_0d_int (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + integer(i4), intent(in) :: ival + + ierr = 0 +# 688 "pio.F90.in" + end function put_var_0d_int +! TYPE int,real,double +# 682 "pio.F90.in" + integer function put_var_0d_real (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r4), intent(in) :: ival + + ierr = 0 +# 688 "pio.F90.in" + end function put_var_0d_real +! TYPE int,real,double +# 682 "pio.F90.in" + integer function put_var_0d_double (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + real(r8), intent(in) :: ival + + ierr = 0 +# 688 "pio.F90.in" + end function put_var_0d_double + +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_0d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_0d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_1d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival(:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_1d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_2d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival(:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_2d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_3d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival(:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_3d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_4d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_4d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_5d_text (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + character(len=*), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_5d_text +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_0d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_0d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_1d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival(:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_1d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_2d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival(:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_2d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_3d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_3d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_4d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_4d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_5d_real (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_5d_real +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_0d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_0d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_1d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival(:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_1d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_2d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival(:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_2d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_3d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival(:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_3d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_4d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_4d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_5d_double (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + real(r8), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_5d_double +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_0d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_0d_int +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_1d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival(:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_1d_int +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_2d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival(:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_2d_int +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_3d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_3d_int +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_4d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_4d_int +! DIMS 0,1,2,3,4,5 +# 691 "pio.F90.in" + integer function put_var_vdesc_5d_int (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + integer(i4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 697 "pio.F90.in" + end function put_var_vdesc_5d_int + +! DIMS 1,2,3,4,5 +! TYPE text +# 701 "pio.F90.in" + integer function put_vara_1d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival(:) + + ierr = 0 +# 707 "pio.F90.in" + end function put_vara_1d_text +! DIMS 1,2,3,4,5 +! TYPE text +# 701 "pio.F90.in" + integer function put_vara_2d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival(:,:) + + ierr = 0 +# 707 "pio.F90.in" + end function put_vara_2d_text +! DIMS 1,2,3,4,5 +! TYPE text +# 701 "pio.F90.in" + integer function put_vara_3d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:) + + ierr = 0 +# 707 "pio.F90.in" + end function put_vara_3d_text +! DIMS 1,2,3,4,5 +! TYPE text +# 701 "pio.F90.in" + integer function put_vara_4d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 707 "pio.F90.in" + end function put_vara_4d_text +! DIMS 1,2,3,4,5 +! TYPE text +# 701 "pio.F90.in" + integer function put_vara_5d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 707 "pio.F90.in" + end function put_vara_5d_text + +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_1d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(in) :: ival(:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_1d_int +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_2d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(in) :: ival(:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_2d_int +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_3d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_3d_int +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_4d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_4d_int +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_5d_int (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_5d_int +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_1d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(in) :: ival(:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_1d_real +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_2d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(in) :: ival(:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_2d_real +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_3d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_3d_real +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_4d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_4d_real +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_5d_real (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_5d_real +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_1d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(in) :: ival(:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_1d_double +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_2d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(in) :: ival(:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_2d_double +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_3d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(in) :: ival(:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_3d_double +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_4d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_4d_double +! TYPE int,real,double +! DIMS 1,2,3,4,5 +# 711 "pio.F90.in" + integer function put_vara_5d_double (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + real(r8), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 717 "pio.F90.in" + end function put_vara_5d_double + +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_1d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(in) :: ival(:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_1d_text +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_2d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(in) :: ival(:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_2d_text +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_3d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_3d_text +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_4d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_4d_text +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_5d_text (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + character(len=*), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_5d_text +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_1d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(in) :: ival(:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_1d_real +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_2d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(in) :: ival(:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_2d_real +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_3d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_3d_real +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_4d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_4d_real +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_5d_real (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_5d_real +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_1d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(in) :: ival(:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_1d_double +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_2d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(in) :: ival(:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_2d_double +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_3d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(in) :: ival(:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_3d_double +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_4d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_4d_double +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_5d_double (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + real(r8), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_5d_double +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_1d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(in) :: ival(:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_1d_int +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_2d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(in) :: ival(:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_2d_int +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_3d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_3d_int +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_4d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_4d_int +! DIMS 1,2,3,4,5 +# 720 "pio.F90.in" + integer function put_vara_vdesc_5d_int (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + integer(i4), intent(in) :: ival(:,:,:,:,:) + + ierr = 0 +# 727 "pio.F90.in" + end function put_vara_vdesc_5d_int + +! TYPE real,int,double +# 730 "pio.F90.in" + subroutine read_darray_1d_real (File,varDesc, ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), dimension(:), intent(inout) :: & + array ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 746 "pio.F90.in" + end subroutine read_darray_1d_real +! TYPE real,int,double +# 730 "pio.F90.in" + subroutine read_darray_1d_int (File,varDesc, ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), dimension(:), intent(inout) :: & + array ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 746 "pio.F90.in" + end subroutine read_darray_1d_int +! TYPE real,int,double +# 730 "pio.F90.in" + subroutine read_darray_1d_double (File,varDesc, ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), dimension(:), intent(inout) :: & + array ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 746 "pio.F90.in" + end subroutine read_darray_1d_double + +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_2d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_2d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_3d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_3d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_4d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_4d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_5d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_5d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_6d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_6d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_7d_real (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r4), intent(inout) :: array(:,:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_7d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_2d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_2d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_3d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_3d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_4d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_4d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_5d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_5d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_6d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_6d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_7d_int (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + integer(i4), intent(inout) :: array(:,:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_7d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_2d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_2d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_3d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_3d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_4d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_4d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_5d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_5d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_6d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_6d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 750 "pio.F90.in" + subroutine read_darray_7d_double (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + real(r8), intent(inout) :: array(:,:,:,:,:,:,:) ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 765 "pio.F90.in" + end subroutine read_darray_7d_double + +# 767 "pio.F90.in" + subroutine setdebuglevel(level) + integer(i4), intent(in) :: level +# 769 "pio.F90.in" + end subroutine setdebuglevel + +# 771 "pio.F90.in" + subroutine seterrorhandlingf(file, method) + type(file_desc_t), intent(inout) :: file + integer, intent(in) :: method +# 774 "pio.F90.in" + end subroutine seterrorhandlingf + +# 776 "pio.F90.in" + subroutine seterrorhandlingi(ios, method) + type(iosystem_desc_t), intent(inout) :: ios + integer, intent(in) :: method +# 779 "pio.F90.in" + end subroutine seterrorhandlingi + +! TYPE real,int,double +# 782 "pio.F90.in" + subroutine write_darray_1d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), dimension(:), target, intent(in) :: & + array ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 800 "pio.F90.in" + end subroutine write_darray_1d_real +! TYPE real,int,double +# 782 "pio.F90.in" + subroutine write_darray_1d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), dimension(:), target, intent(in) :: & + array ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 800 "pio.F90.in" + end subroutine write_darray_1d_int +! TYPE real,int,double +# 782 "pio.F90.in" + subroutine write_darray_1d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), dimension(:), target, intent(in) :: & + array ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 800 "pio.F90.in" + end subroutine write_darray_1d_double + +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_2d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_2d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_3d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_3d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_4d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:,:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_4d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_5d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:,:,:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_5d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_6d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:,:,:,:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_6d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_7d_real (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r4), intent(in) :: & + array(:,:,:,:,:,:,:) ! array to be written + + real(r4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_7d_real +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_2d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_2d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_3d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_3d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_4d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:,:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_4d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_5d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:,:,:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_5d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_6d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:,:,:,:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_6d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_7d_int (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + integer(i4), intent(in) :: & + array(:,:,:,:,:,:,:) ! array to be written + + integer(i4), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_7d_int +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_2d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_2d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_3d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_3d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_4d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:,:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_4d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_5d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:,:,:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_5d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_6d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:,:,:,:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_6d_double +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 +# 804 "pio.F90.in" + subroutine write_darray_7d_double (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + real(r8), intent(in) :: & + array(:,:,:,:,:,:,:) ! array to be written + + real(r8), optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 +# 822 "pio.F90.in" + end subroutine write_darray_7d_double + +end module pio diff --git a/share/csm_share/unit_test_stubs/pio/pio.F90.in b/share/csm_share/unit_test_stubs/pio/pio.F90.in new file mode 100644 index 000000000000..3d91f608289e --- /dev/null +++ b/share/csm_share/unit_test_stubs/pio/pio.F90.in @@ -0,0 +1,824 @@ +module pio + ! This module provides a stub implementation of a subset of PIO. + ! + ! This can be used when you need the PIO interfaces in order for your unit tests to + ! build, but do not actually need to make use of any of the PIO functionality in your + ! unit tests. + + ! Note that not all PIO functionality is stubbed here. Stubs are written on an + ! as-needed basis, and others can be added here as needed. + + ! Note about organization: variables, functions/subroutines, etc. should be kept in + ! alphabetical order to facilitate finding what you want. Currently, this is roughly + ! true, though is violated for specific routines within a group (e.g., implementations + ! of the initdecomp interface). + + ! NOTE(wjs, 2015-01-12) In some routines here, variables that are declared as + ! intent(out) in the real code are declared intent(inout) here. I am using intent(inout) + ! because I do not want to bother with assigning a value to these, and some compilers + ! complain if you don't assign a value to an intent(out) argument. + + +! uses mpi if available +#ifndef NO_MPIMOD + use mpi, only : MPI_OFFSET_KIND ! _EXTERNAL +#endif + + implicit none + private + +#ifdef NO_MPIMOD + include 'mpif.h' ! _EXTERNAL +#endif + + type, public :: file_desc_t + end type file_desc_t + + type, public :: io_desc_t + end type io_desc_t + + type, public :: iosystem_desc_t + end type iosystem_desc_t + + type, public :: var_desc_t + end type var_desc_t + + integer, parameter, private :: & + i4 = selected_int_kind(6) ,& + i8 = selected_int_kind(13) ,& + r4 = selected_real_kind(6) ,& + r8 = selected_real_kind(13) + + integer, parameter, public :: PIO_64BIT_OFFSET = 0 + integer(i4), parameter, public :: PIO_BCAST_ERROR = 0 + integer, parameter, public :: PIO_CLOBBER = 0 + integer, parameter, public :: PIO_DOUBLE = 0 + integer, parameter, public :: PIO_GLOBAL = 0 + integer, parameter, public :: PIO_INT = 0 + integer(i4), parameter, public :: PIO_INTERNAL_ERROR = 0 + integer, parameter, public :: PIO_iotype_netcdf = 0 + integer, parameter, public :: PIO_iotype_netcdf4c = 0 + integer, parameter, public :: PIO_iotype_netcdf4p = 0 + integer, parameter, public :: PIO_iotype_pnetcdf = 0 + integer, parameter, public :: PIO_NOWRITE = 0 + integer, parameter, public :: pio_offset = MPI_OFFSET_KIND + integer, parameter, public :: pio_offset_kind = pio_offset + integer, parameter, public :: pio_rearr_subset = 0 + integer, parameter, public :: PIO_WRITE = 0 + + public :: PIO_def_dim + public :: PIO_enddef + public :: PIO_FILE_IS_OPEN + public :: pio_inq_dimid + public :: pio_inq_dimlen + public :: pio_set_blocksize + + public :: PIO_closefile + interface PIO_closefile + module procedure closefile + end interface PIO_closefile + + public :: PIO_createfile + interface PIO_createfile + module procedure createfile + end interface + + public :: pio_def_var + interface pio_def_var + module procedure & + def_var_0d, & + def_var_md + end interface + + public :: PIO_finalize + interface PIO_finalize + module procedure finalize + end interface + + public :: PIO_freedecomp + interface PIO_freedecomp + module procedure freedecomp_ios + module procedure freedecomp_file + end interface + + public :: pio_get_att + interface pio_get_att + module procedure get_att_{TYPE}, get_att_desc_{TYPE} + ! TYPE real,int,double + module procedure get_att_1d_{TYPE}, get_att_desc_1d_{TYPE} + end interface + + public :: pio_get_var + interface pio_get_var + module procedure get_var_{DIMS}d_{TYPE}, get_var_vdesc_{DIMS}d_{TYPE} + ! DIMS 1,2,3,4,5 + module procedure get_vara_{DIMS}d_{TYPE}, get_vara_vdesc_{DIMS}d_{TYPE} + module procedure get_var1_{TYPE}, get_var1_vdesc_{TYPE} + end interface + + public :: PIO_init + interface PIO_init + module procedure init_intracom + module procedure init_intercom + end interface + + public :: PIO_initdecomp + interface PIO_initdecomp + module procedure PIO_initdecomp_dof_i4 ! previous name: initdecomop_1dof_nf_box + module procedure PIO_initdecomp_dof_i8 ! previous name: initdecomop_1dof_nf_box + module procedure PIO_initdecomp_dof_i8_vdc + module procedure initdecomp_1dof_nf_i4 + module procedure initdecomp_1dof_nf_i8 + module procedure initdecomp_1dof_bin_i4 + module procedure initdecomp_1dof_bin_i8 + module procedure initdecomp_2dof_nf_i4 + module procedure initdecomp_2dof_nf_i8 + module procedure initdecomp_2dof_bin_i4 + module procedure initdecomp_2dof_bin_i8 + module procedure PIO_initdecomp_bc + module procedure PIO_initdecomp_dof_dof + end interface + + public :: pio_inq_varid + interface pio_inq_varid + module procedure inq_varid_vid, & + inq_varid_vardesc + end interface pio_inq_varid + + public :: PIO_openfile + interface PIO_openfile + module procedure PIO_openfile + end interface + + public :: PIO_put_att + interface PIO_put_att + module procedure put_att_{TYPE}, put_att_desc_{TYPE} + ! TYPE real,int,double + module procedure put_att_1d_{TYPE}, put_att_desc_1d_{TYPE} + end interface + + public :: pio_put_var + interface pio_put_var + ! DIMS 0,1,2,3,4,5 + module procedure put_var_{DIMS}d_{TYPE}, put_var_vdesc_{DIMS}d_{TYPE} + ! DIMS 1,2,3,4,5 + module procedure put_vara_{DIMS}d_{TYPE}, put_vara_vdesc_{DIMS}d_{TYPE} + module procedure put_var1_{TYPE}, put_var1_vdesc_{TYPE} + end interface + + public :: PIO_read_darray + interface PIO_read_darray +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure read_darray_{DIMS}d_{TYPE} + end interface + + public :: pio_set_buffer_size_limit + interface pio_set_buffer_size_limit + module procedure pio_set_buffer_size_limit_i4 + module procedure pio_set_buffer_size_limit_i8 + end interface + + public :: PIO_setdebuglevel + interface PIO_setdebuglevel + module procedure setdebuglevel + end interface PIO_setdebuglevel + + public :: PIO_seterrorhandling + interface PIO_seterrorhandling + module procedure seterrorhandlingf + module procedure seterrorhandlingi + end interface + + public :: PIO_write_darray + interface PIO_write_darray +! TYPE real,int,double +! DIMS 1,2,3,4,5,6,7 + module procedure write_darray_{DIMS}d_{TYPE} + end interface + +contains + + subroutine closefile(file) + type (file_desc_t),intent(inout) :: file + end subroutine closefile + + integer function createfile(iosystem, file,iotype, fname, amode_in) result(ierr) + type (iosystem_desc_t), intent(inout), target :: iosystem + type (file_desc_t), intent(inout) :: file + integer, intent(in) :: iotype + character(len=*), intent(in) :: fname + integer, optional, intent(in) :: amode_in + + ierr = 0 + end function createfile + + integer function def_var_0d(File,name,type,vardesc) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(in) :: type + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 + end function def_var_0d + + integer function def_var_md(File,name,type,dimids,vardesc) result(ierr) + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(in) :: type + integer, intent(in) :: dimids(:) + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 + end function def_var_md + + subroutine finalize(iosystem,ierr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(out) :: ierr + + ierr = 0 + end subroutine finalize + + subroutine freedecomp_ios(ios,iodesc) + type (iosystem_desc_t) :: ios + type (io_desc_t) :: iodesc + end subroutine freedecomp_ios + + subroutine freedecomp_file(file,iodesc) + type (file_desc_t) :: file + type (io_desc_t) :: iodesc + end subroutine freedecomp_file + + integer function get_att_desc_{TYPE} (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + {VTYPE}, intent(inout) :: value + + ierr = 0 + end function get_att_desc_{TYPE} + +! TYPE real,int,double + integer function get_att_desc_1d_{TYPE} (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + {VTYPE}, intent(inout) :: value(:) + + ierr = 0 + end function get_att_desc_1d_{TYPE} + + integer function get_att_{TYPE} (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + {VTYPE}, intent(inout) :: value + + ierr = 0 + end function get_att_{TYPE} + +! TYPE real,int,double + integer function get_att_1d_{TYPE} (File,varid,name,value) result(ierr) + type (File_desc_t), intent(in) , target :: File + integer(i4), intent(in) :: varid + character(len=*), intent(in) :: name + {VTYPE}, intent(inout) :: value(:) + + ierr = 0 + end function get_att_1d_{TYPE} + + integer function get_var1_{TYPE} (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, index(:) + {VTYPE}, intent(inout) :: ival + + ierr = 0 + end function get_var1_{TYPE} + + integer function get_var1_vdesc_{TYPE} (File,vardesc, index, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: index(:) + {VTYPE}, intent(inout) :: ival + + ierr = 0 + end function get_var1_vdesc_{TYPE} + +! DIMS 1,2,3,4,5 + integer function get_vara_{DIMS}d_{TYPE} (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid, start(:), count(:) + {VTYPE}, intent(inout) :: ival{DIMSTR} + + ierr = 0 + end function get_vara_{DIMS}d_{TYPE} + +! DIMS 1,2,3,4,5 + integer function get_vara_vdesc_{DIMS}d_{TYPE} (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + {VTYPE}, intent(inout) :: ival{DIMSTR} + + ierr = 0 + end function get_vara_vdesc_{DIMS}d_{TYPE} + + integer function get_var_{DIMS}d_{TYPE} (File,varid, ival) result(ierr) + type (File_desc_t), intent(in) :: File + integer, intent(in) :: varid + {VTYPE}, intent(inout) :: ival{DIMSTR} + + ierr = 0 + end function get_var_{DIMS}d_{TYPE} + + integer function get_var_vdesc_{DIMS}d_{TYPE} (File,vardesc, ival) result(ierr) + type (File_desc_t), intent(in) :: File + type(var_desc_t), intent(in) :: vardesc + {VTYPE}, intent(inout) :: ival{DIMSTR} + + ierr = 0 + end function get_var_vdesc_{DIMS}d_{TYPE} + + subroutine init_intracom(comp_rank, comp_comm, num_iotasks, num_aggregator, stride, rearr, iosystem,base) + integer(i4), intent(in) :: comp_rank + integer(i4), intent(in) :: comp_comm + integer(i4), intent(in) :: num_iotasks + integer(i4), intent(in) :: num_aggregator + integer(i4), intent(in) :: stride + integer(i4), intent(in) :: rearr + type (iosystem_desc_t), intent(inout) :: iosystem ! io descriptor to initalize + + integer(i4), intent(in),optional :: base + end subroutine init_intracom + + subroutine init_intercom(component_count, peer_comm, comp_comms, io_comm, iosystem) + integer, intent(in) :: component_count + integer, intent(in) :: peer_comm + integer, intent(in) :: comp_comms(component_count) ! The compute communicator + integer, intent(in) :: io_comm ! The io communicator + + type (iosystem_desc_t), intent(inout) :: iosystem(component_count) ! io descriptor to initalize + end subroutine init_intercom + + subroutine PIO_initdecomp_bc(iosystem,basepiotype,dims,compstart,compcount,iodesc,iostart,iocount) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (kind=PIO_OFFSET) :: compstart(:) + integer (kind=PIO_OFFSET) :: compcount(:) + type (IO_desc_t), intent(inout) :: iodesc + integer (kind=PIO_OFFSET),optional :: iostart(:) + integer (kind=PIO_OFFSET),optional :: iocount(:) + end subroutine PIO_initdecomp_bc + + subroutine PIO_initdecomp_dof_dof(iosystem,basepiotype,dims,compdof,iodesc,iodof) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer(i4), intent(in) :: compdof(:) + type (IO_desc_t), intent(inout) :: iodesc + integer(i4), intent(in) :: iodof(:) + end subroutine PIO_initdecomp_dof_dof + + subroutine initdecomp_2dof_bin_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) !> global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) !> global degrees of freedom for io decomposition + integer (i4), intent(in) :: iodofw(:) !> global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + end subroutine initdecomp_2dof_bin_i4 + + subroutine initdecomp_2dof_bin_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) !> global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodofr(:) !> global degrees of freedom for io decomposition + integer (kind=pio_offset), intent(in) :: iodofw(:) !> global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + end subroutine initdecomp_2dof_bin_i8 + + subroutine initdecomp_1dof_bin_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer(i4), intent(in) :: lenblocks + integer(kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer(kind=pio_offset), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + end subroutine initdecomp_1dof_bin_i8 + + subroutine initdecomp_1dof_bin_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + end subroutine initdecomp_1dof_bin_i4 + + subroutine initdecomp_2dof_nf_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + integer (i4), intent(in) :: iodofw(:) ! global degrees of freedom for io decomposition + + type (io_desc_t), intent(inout) :: iodesc + + integer(kind=PIO_offset), intent(in) :: start(:), count(:) + end subroutine initdecomp_2dof_nf_i4 + + subroutine initdecomp_2dof_nf_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodofr,iodofw,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodofr(:) ! global degrees of freedom for io decomposition + integer (kind=pio_offset), intent(in) :: iodofw(:) ! global degrees of freedom for io decomposition + + type (io_desc_t), intent(inout) :: iodesc + + integer(kind=PIO_offset), intent(in) :: start(:), count(:) + end subroutine initdecomp_2dof_nf_i8 + + subroutine initdecomp_1dof_nf_i4(iosystem,basepiotype,dims,lenblocks,compdof,iodof,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (i4), intent(in) :: iodof(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + integer :: piotype + integer(kind=PIO_offset), intent(in) :: start(:), count(:) + end subroutine initdecomp_1dof_nf_i4 + + subroutine initdecomp_1dof_nf_i8(iosystem,basepiotype,dims,lenblocks,compdof,iodof,start, count, iodesc) + type (iosystem_desc_t), intent(in) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (i4), intent(in) :: lenblocks + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=pio_offset), intent(in) :: iodof(:) ! global degrees of freedom for io decomposition + type (io_desc_t), intent(inout) :: iodesc + integer :: piotype + integer(kind=PIO_offset), intent(in) :: start(:), count(:) + end subroutine initdecomp_1dof_nf_i8 + + subroutine PIO_initdecomp_dof_i4(iosystem,basepiotype,dims,compdof, iodesc, iostart, iocount, num_ts, bsize, rearr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=PIO_offset), optional :: iostart(:), iocount(:) + type (io_desc_t), intent(inout) :: iodesc + integer(i4), intent(in) :: dims(:) + integer, intent(in), optional :: rearr + !vdf optionals + integer(i4), intent(in), optional:: num_ts, bsize(3) + end subroutine PIO_initdecomp_dof_i4 + + subroutine PIO_initdecomp_dof_i8(iosystem,basepiotype,dims,compdof, iodesc, iostart, iocount, rearr) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: basepiotype + integer(i4), intent(in) :: dims(:) + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + integer (kind=PIO_offset), optional :: iostart(:), iocount(:) + type (io_desc_t), intent(inout) :: iodesc + integer, intent(in), optional :: rearr + end subroutine PIO_initdecomp_dof_i8 + + subroutine PIO_initdecomp_dof_i8_vdc(iosystem,dims,compdof, iodesc, num_ts, bsize) + type (iosystem_desc_t), intent(inout) :: iosystem + integer(i4), intent(in) :: dims(:) + integer (kind=pio_offset), intent(in) :: compdof(:) ! global degrees of freedom for computational decomposition + + type (io_desc_t), intent(inout) :: iodesc + !vdc args + integer(i4), intent(in) :: num_ts + integer(i4), intent(in), optional:: bsize(3) + end subroutine PIO_initdecomp_dof_i8_vdc + + integer function inq_varid_vardesc(File,name,vardesc) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + type (Var_desc_t), intent(inout) :: vardesc + + ierr = 0 + end function inq_varid_vardesc + + integer function inq_varid_vid(File,name,varid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer(i4), intent(out) :: varid + + varid = 0 + ierr = 0 + end function inq_varid_vid + + + integer function PIO_def_dim(File,name,len,dimid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer(i4), intent(in) :: len + integer(i4), intent(out) :: dimid + + dimid = 0 + ierr = 0 + end function PIO_def_dim + + integer function PIO_enddef(File) result(ierr) + type (File_desc_t), intent(inout) :: File + + ierr = 0 + end function PIO_enddef + + logical function PIO_FILE_IS_OPEN(File) + type(file_desc_t), intent(in) :: file + + PIO_FILE_IS_OPEN = .false. + end function PIO_FILE_IS_OPEN + + integer function pio_inq_dimid(File,name,dimid) result(ierr) + + type (File_desc_t), intent(in) :: File + character(len=*), intent(in) :: name + integer, intent(out) :: dimid !dimension ID + + dimid = 0 + ierr = 0 + end function pio_inq_dimid + + integer function pio_inq_dimlen(File,dimid,dimlen) result(ierr) + + type (File_desc_t), intent(in) :: File + integer(i4) , intent(in) :: dimid + integer(i4) , intent(out) :: dimlen !dimension name + + dimlen = 0 + ierr = 0 + end function pio_inq_dimlen + + integer function PIO_openfile(iosystem, file, iotype, fname,mode, CheckMPI) result(ierr) + type (iosystem_desc_t), intent(inout), target :: iosystem + type (file_desc_t), intent(out) :: file + integer, intent(in) :: iotype + character(len=*), intent(in) :: fname + integer, optional, intent(in) :: mode + logical, optional, intent(in) :: CheckMPI + + ierr = 0 + end function PIO_openfile + + subroutine pio_set_blocksize(newsize) + integer, intent(in) :: newsize + end subroutine pio_set_blocksize + + subroutine pio_set_buffer_size_limit_i4(limit) + integer, intent(in) :: limit + end subroutine pio_set_buffer_size_limit_i4 + + subroutine pio_set_buffer_size_limit_i8(limit) + integer(pio_offset), intent(in) :: limit + end subroutine pio_set_buffer_size_limit_i8 + + integer function put_att_{TYPE} (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + {VTYPE}, intent(in) :: value + + ierr = 0 + end function put_att_{TYPE} + +! TYPE real,double,int + integer function put_att_1d_{TYPE} (File, varid, name, value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: name + {VTYPE}, intent(in) :: value(:) + + ierr = 0 + end function put_att_1d_{TYPE} + + integer function put_att_desc_{TYPE} (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + {VTYPE}, intent(in) :: value + + ierr = 0 + end function put_att_desc_{TYPE} + +! TYPE real,int,double + integer function put_att_desc_1d_{TYPE} (File,varDesc,name,value) result(ierr) + type (File_desc_t), intent(inout) , target :: File + type (VAR_desc_t), intent(in) :: varDesc + character(len=*), intent(in) :: name + {VTYPE}, intent(in) :: value(:) + + ierr = 0 + end function put_att_desc_1d_{TYPE} + + integer function put_var1_text (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + character(len=*), intent(in) :: ival + + ierr = 0 + end function put_var1_text + +! TYPE int,real,double + integer function put_var1_{TYPE} (File,varid, index, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, index(:) + {VTYPE}, intent(in) :: ival + + ierr = 0 + end function put_var1_{TYPE} + + integer function put_var1_vdesc_{TYPE} (File,vardesc, start, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:) + {VTYPE}, intent(in) :: ival + + ierr = 0 + end function put_var1_vdesc_{TYPE} + +! DIMS 0,1,2,3,4,5 +! TYPE text + integer function put_var_{DIMS}d_text (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + character(len=*), intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_var_{DIMS}d_text + +! DIMS 1,2,3,4,5 +! TYPE int,real,double + integer function put_var_{DIMS}d_{TYPE} (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + {VTYPE}, intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_var_{DIMS}d_{TYPE} + +! TYPE int,real,double + integer function put_var_0d_{TYPE} (File,varid, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid + {VTYPE}, intent(in) :: ival + + ierr = 0 + end function put_var_0d_{TYPE} + +! DIMS 0,1,2,3,4,5 + integer function put_var_vdesc_{DIMS}d_{TYPE} (File, vardesc, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t) , intent(in) :: vardesc + {VTYPE}, intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_var_vdesc_{DIMS}d_{TYPE} + +! DIMS 1,2,3,4,5 +! TYPE text + integer function put_vara_{DIMS}d_text (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + character(len=*), intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_vara_{DIMS}d_text + +! TYPE int,real,double +! DIMS 1,2,3,4,5 + integer function put_vara_{DIMS}d_{TYPE} (File,varid, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + integer, intent(in) :: varid, start(:), count(:) + {VTYPE}, intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_vara_{DIMS}d_{TYPE} + +! DIMS 1,2,3,4,5 + integer function put_vara_vdesc_{DIMS}d_{TYPE} (File,vardesc, start, count, ival) result(ierr) + type (File_desc_t), intent(inout) :: File + type(var_desc_t), intent(in) :: vardesc + integer, intent(in) :: start(:), count(:) + {VTYPE}, intent(in) :: ival{DIMSTR} + + ierr = 0 + end function put_vara_vdesc_{DIMS}d_{TYPE} + +! TYPE real,int,double + subroutine read_darray_1d_{TYPE} (File,varDesc, ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + {VTYPE}, dimension(:), intent(inout) :: & + array ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 + end subroutine read_darray_1d_{TYPE} + +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 + subroutine read_darray_{DIMS}d_{TYPE} (File,varDesc,ioDesc, array, iostat) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! iodecomp descriptor + + {VTYPE}, intent(inout) :: array{DIMSTR} ! array to be read + + integer(i4), intent(out) :: iostat + + iostat = 0 + end subroutine read_darray_{DIMS}d_{TYPE} + + subroutine setdebuglevel(level) + integer(i4), intent(in) :: level + end subroutine setdebuglevel + + subroutine seterrorhandlingf(file, method) + type(file_desc_t), intent(inout) :: file + integer, intent(in) :: method + end subroutine seterrorhandlingf + + subroutine seterrorhandlingi(ios, method) + type(iosystem_desc_t), intent(inout) :: ios + integer, intent(in) :: method + end subroutine seterrorhandlingi + +! TYPE real,int,double + subroutine write_darray_1d_{TYPE} (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + {VTYPE}, dimension(:), target, intent(in) :: & + array ! array to be written + + {VTYPE}, optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 + end subroutine write_darray_1d_{TYPE} + +! TYPE real,int,double +! DIMS 2,3,4,5,6,7 + subroutine write_darray_{DIMS}d_{TYPE} (File,varDesc,ioDesc, array, iostat, fillval) + type (File_desc_t), intent(inout) :: & + File ! file information + + type (var_desc_t), intent(inout) :: & + varDesc ! variable descriptor + + type (io_desc_t), intent(inout) :: & + ioDesc ! variable descriptor + + {VTYPE}, intent(in) :: & + array{DIMSTR} ! array to be written + + {VTYPE}, optional, intent(in) :: fillval ! rearrange receiver fill value + + integer(i4), intent(out) :: iostat + + iostat = 0 + end subroutine write_darray_{DIMS}d_{TYPE} + +end module pio diff --git a/share/esmf_wrf_timemgr/CMakeLists.txt b/share/esmf_wrf_timemgr/CMakeLists.txt new file mode 100644 index 000000000000..d27480573c09 --- /dev/null +++ b/share/esmf_wrf_timemgr/CMakeLists.txt @@ -0,0 +1,19 @@ +list(APPEND esmf_wrf_timemgr_sources + ESMF.F90 + ESMF_AlarmClockMod.F90 + ESMF_AlarmMod.F90 + ESMF_BaseMod.F90 + ESMF_BaseTimeMod.F90 + ESMF_CalendarMod.F90 + ESMF_ClockMod.F90 + ESMF_FractionMod.F90 + ESMF_ShrTimeMod.F90 + ESMF_Stubs.F90 + ESMF_TimeIntervalMod.F90 + ESMF_TimeMod.F90 + MeatMod.F90 + wrf_error_fatal.F90 + wrf_message.F90 + ) + +sourcelist_to_parent(esmf_wrf_timemgr_sources) \ No newline at end of file diff --git a/share/esmf_wrf_timemgr/ESMF.F90 b/share/esmf_wrf_timemgr/ESMF.F90 new file mode 100644 index 000000000000..8eb5b7a181f9 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF.F90 @@ -0,0 +1,19 @@ +! TBH: This version is for use with the ESMF library embedded in the WRF +! TBH: distribution. +MODULE ESMF + USE ESMF_AlarmMod + USE ESMF_BaseMod + USE ESMF_BaseTimeMod + USE ESMF_CalendarMod + USE ESMF_ClockMod + USE ESMF_FractionMod + USE ESMF_TimeIntervalMod + USE ESMF_TimeMod + USE ESMF_ShrTimeMod + USE ESMF_AlarmClockMod + USE ESMF_Stubs ! add new dummy interfaces and typedefs here as needed + USE MeatMod +#include + INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS +! +END MODULE ESMF diff --git a/share/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 b/share/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 new file mode 100644 index 000000000000..63932f91f706 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_AlarmClockMod.F90 @@ -0,0 +1,102 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Alarm-Clock Module + module ESMF_AlarmClockMod +! +!============================================================================== +! +! This file contains the AlarmCreae method. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!=============================================================================== +!BOPI +! +! !MODULE: ESMF_AlarmClockMod +! +! !DESCRIPTION: +! Separate module that uses both ESMF_AlarmMod and ESMF_ClockMod. +! Separation is needed to avoid cyclic dependence. +! +! Defines F90 wrapper entry points for corresponding +! C++ class {\tt ESMC\_Alarm} +! +! See {\tt ../include/ESMC\_Alarm.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit ESMF_Alarm and ESMF_Clock + use ESMF_AlarmMod, only : ESMF_Alarm, ESMF_AlarmSet + use ESMF_ClockMod, only : ESMF_Clock, ESMF_ClockAddAlarm + + ! associated derived types + use ESMF_TimeIntervalMod, only : ESMF_TimeInterval + use ESMF_TimeMod, only : ESMF_Time + + implicit none + +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ + +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_AlarmCreate + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== + + contains + +!============================================================================== + + +! Create ESMF_Alarm using ESMF 2.1.0+ semantics + FUNCTION ESMF_AlarmCreate( name, clock, RingTime, RingInterval, & + StopTime, Enabled, rc ) + + ! return value + type(ESMF_Alarm) :: ESMF_AlarmCreate + ! !ARGUMENTS: + character(len=*), intent(in) :: name + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_Time), intent(in), optional :: RingTime + type(ESMF_TimeInterval), intent(in), optional :: RingInterval + type(ESMF_Time), intent(in), optional :: StopTime + logical, intent(in), optional :: Enabled + integer, intent(out), optional :: rc + ! locals + type(ESMF_Alarm) :: alarmtmp + ! TBH: ignore allocate errors, for now + ALLOCATE( alarmtmp%alarmint ) + CALL ESMF_AlarmSet( alarmtmp, & + name=name, & + RingTime=RingTime, & + RingInterval=RingInterval, & + StopTime=StopTime, & + Enabled=Enabled, & + rc=rc ) + CALL ESMF_ClockAddAlarm( clock, alarmtmp, rc ) + ESMF_AlarmCreate = alarmtmp + END FUNCTION ESMF_AlarmCreate + + +!------------------------------------------------------------------------------ + + end module ESMF_AlarmClockMod diff --git a/share/esmf_wrf_timemgr/ESMF_AlarmMod.F90 b/share/esmf_wrf_timemgr/ESMF_AlarmMod.F90 new file mode 100644 index 000000000000..67400ae7e60c --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_AlarmMod.F90 @@ -0,0 +1,1042 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Alarm Module + module ESMF_AlarmMod +! +!============================================================================== +! +! This file contains the Alarm class definition and all Alarm class +! methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!=============================================================================== +!BOPI +! +! !MODULE: ESMF_AlarmMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ class {\tt ESMC\_Alarm} +! +! See {\tt ../include/ESMC\_Alarm.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! associated derived types + use ESMF_TimeIntervalMod + use ESMF_TimeMod + + implicit none + +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Alarm +! +! ! F90 class type to match C++ Alarm class in size only; +! ! all dereferencing within class is performed by C++ implementation + +! internals for ESMF_Alarm + type ESMF_AlarmInt + character(len=256) :: name = " " + type(ESMF_TimeInterval) :: RingInterval + type(ESMF_Time) :: RingTime + type(ESMF_Time) :: PrevRingTime + type(ESMF_Time) :: StopTime + integer :: ID + integer :: AlarmMutex + logical :: Ringing + logical :: Enabled + logical :: RingTimeSet + logical :: RingIntervalSet + logical :: StopTimeSet + end type + +! Actual public type: this bit allows easy mimic of "deep" ESMF_AlarmCreate +! in ESMF 2.1.0+. Note that ESMF_AlarmCreate is in a separate module to avoid +! cyclic dependence. +! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF +! shallow-copy-masquerading-as-reference-copy insanity. + type ESMF_Alarm + type(ESMF_AlarmInt), pointer :: alarmint => null() + end type + +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_Alarm + public ESMF_AlarmInt ! needed on AIX but not PGI +!------------------------------------------------------------------------------ + +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_AlarmDestroy + public ESMF_AlarmSet + public ESMF_AlarmGet +! public ESMF_AlarmGetRingInterval +! public ESMF_AlarmSetRingInterval +! public ESMF_AlarmGetRingTime +! public ESMF_AlarmSetRingTime +! public ESMF_AlarmGetPrevRingTime +! public ESMF_AlarmSetPrevRingTime +! public ESMF_AlarmGetStopTime +! public ESMF_AlarmSetStopTime + public ESMF_AlarmEnable + public ESMF_AlarmDisable + public ESMF_AlarmRingerOn + public ESMF_AlarmRingerOff + public ESMF_AlarmIsRinging +! public ESMF_AlarmCheckRingTime + public operator(==) + +! Required inherited and overridden ESMF_Base class methods + +! public ESMF_AlarmRead +! public ESMF_AlarmWrite + public ESMF_AlarmValidate + public ESMF_AlarmPrint + +! !PRIVATE MEMBER FUNCTIONS: + private ESMF_AlarmEQ +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== +! +! INTERFACE BLOCKS +! +!============================================================================== +!BOP +! !INTERFACE: + interface operator(==) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_AlarmEQ + +! !DESCRIPTION: +! This interface overloads the == operator for the {\tt ESMF\_Alarm} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ + +!============================================================================== + + contains + +!============================================================================== + +!------------------------------------------------------------------------------ +! +! This section includes the Set methods. +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmSet - Initializes an alarm + +! !INTERFACE: + subroutine ESMF_AlarmSet(alarm, name, RingTime, RingInterval, & + StopTime, Enabled, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + character(len=*), intent(in), optional :: name + type(ESMF_Time), intent(in), optional :: RingTime + type(ESMF_TimeInterval), intent(in), optional :: RingInterval + type(ESMF_Time), intent(in), optional :: StopTime + logical, intent(in), optional :: Enabled + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Initializes an {\tt ESMF\_Alarm} +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to initialize +! \item[{[RingTime]}] +! Optional ring time for one-shot or first repeating alarm +! \item[{[RingInterval]}] +! Optional ring interval for repeating alarms +! \item[{[StopTime]}] +! Optional stop time for repeating alarms +! \item[Enabled] +! Alarm enabled/disabled +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.1, TMG4.7 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + alarm%alarmint%RingTimeSet = .FALSE. + alarm%alarmint%RingIntervalSet = .FALSE. + alarm%alarmint%StopTimeSet = .FALSE. + IF ( PRESENT( name ) ) THEN + alarm%alarmint%name = name + END IF + IF ( PRESENT( RingInterval ) ) THEN + alarm%alarmint%RingInterval = RingInterval + alarm%alarmint%RingIntervalSet = .TRUE. + ENDIF + IF ( PRESENT( RingTime ) ) THEN + alarm%alarmint%RingTime = RingTime + alarm%alarmint%RingTimeSet = .TRUE. + ENDIF + IF ( PRESENT( StopTime ) ) THEN + alarm%alarmint%StopTime = StopTime + alarm%alarmint%StopTimeSet = .TRUE. + ENDIF + alarm%alarmint%Enabled = .TRUE. + IF ( PRESENT( Enabled ) ) THEN + alarm%alarmint%Enabled = Enabled + ENDIF + IF ( PRESENT( rc ) ) THEN + rc = ESMF_SUCCESS + ENDIF + alarm%alarmint%Ringing = .FALSE. + alarm%alarmint%Enabled = .TRUE. + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + + end subroutine ESMF_AlarmSet + + + +! Deallocate memory for ESMF_Alarm + SUBROUTINE ESMF_AlarmDestroy( alarm, rc ) + TYPE(ESMF_Alarm), INTENT(INOUT) :: alarm + INTEGER, INTENT( OUT), OPTIONAL :: rc + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + DEALLOCATE( alarm%alarmint ) + ENDIF + ! TBH: ignore deallocate errors, for now + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + END SUBROUTINE ESMF_AlarmDestroy + + + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmGetRingInterval - Get an alarm's ring interval +! +! !INTERFACE: + subroutine ESMF_AlarmGetRingInterval(alarm, RingInterval, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + type(ESMF_TimeInterval), intent(out) :: RingInterval + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Alarm}'s ring interval +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to get the ring interval +! \item[RingInterval] +! The {\tt Alarm}'s ring interval +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.7 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingIntervalSet )THEN + RingInterval= alarm%alarmint%RingInterval + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + END IF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmGetRingInterval + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmSetRingInterval - Set an alarm's ring interval +! +! !INTERFACE: + subroutine ESMF_AlarmSetRingInterval(alarm, RingInterval, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(out) :: alarm + type(ESMF_TimeInterval), intent(in) :: RingInterval + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Alarm}'s ring interval +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to set the ring interval +! \item[RingInterval] +! The {\tt Alarm}'s ring interval +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.5.2, TMG4.7 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmSetRingInterval not supported' ) + end subroutine ESMF_AlarmSetRingInterval + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmGetRingTime - Get an alarm's time to ring +! +! !INTERFACE: + subroutine ESMF_AlarmGetRingTime(alarm, RingTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + type(ESMF_Time), intent(out) :: RingTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Alarm}'s time to ring +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to get the ring time +! \item[RingTime] +! The {\tt ESMF\_Alarm}'s ring time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.7, TMG4.8 +!EOP + type(ESMF_Time) :: PrevRingTime + type(ESMF_TimeInterval) :: RingInterval + integer :: ierr + + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingIntervalSet )THEN + PrevRingTime = alarm%alarmint%PrevRingTime + call ESMF_AlarmGetRingInterval( alarm, RingInterval, ierr) + IF ( PRESENT( rc ) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + return + END IF + RingTime = PrevRingTime + RingInterval + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE IF ( alarm%alarmint%RingTimeSet )THEN + RingTime = alarm%alarmint%RingTime + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + END IF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmGetRingTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmSetRingTime - Set an alarm's time to ring +! +! !INTERFACE: + subroutine ESMF_AlarmSetRingTime(alarm, RingTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(out) :: alarm + type(ESMF_Time), intent(in) :: RingTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Alarm}'s time to ring +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to set the ring time +! \item[RingTime] +! The {\tt ESMF\_Alarm}'s ring time to set +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.5.1, TMG4.7, TMG4.8 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmSetRingTime not supported' ) + end subroutine ESMF_AlarmSetRingTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmGet - Get an alarm's parameters -- compatibility with ESMF 2.0.1 +! +! !INTERFACE: + subroutine ESMF_AlarmGet(alarm, name, RingTime, PrevRingTime, RingInterval, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + character(len=*), intent(out), optional :: name + type(ESMF_Time), intent(out), optional :: RingTime + type(ESMF_Time), intent(out), optional :: PrevRingTime + type(ESMF_TimeInterval), intent(out), optional :: RingInterval + integer, intent(out), optional :: rc + integer :: ierr + +! !DESCRIPTION: +! Get an {\tt ESMF\_Alarm}'s previous ring time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to get +! \item[ringTime] +! The ring time for a one-shot alarm or the next repeating alarm. +! \item[ringInterval] +! The ring interval for repeating (interval) alarms. +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.7, TMG4.8 +!EOP + + ierr = ESMF_SUCCESS + + IF ( PRESENT(name) ) THEN + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + name = alarm%alarmint%name + ELSE + ierr = ESMF_FAILURE + END IF + ENDIF + IF ( PRESENT(PrevRingTime) ) THEN + CALL ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc=ierr) + ENDIF + IF ( PRESENT(RingTime) ) THEN + CALL ESMF_AlarmGetRingTime(alarm, RingTime, rc=ierr) + ENDIF + IF ( PRESENT(RingInterval) ) THEN + CALL ESMF_AlarmGetRingInterval(alarm, RingInterval, rc=ierr) + ENDIF + + IF ( PRESENT(rc) ) THEN + rc = ierr + ENDIF + + end subroutine ESMF_AlarmGet + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmGetPrevRingTime - Get an alarm's previous ring time +! +! !INTERFACE: + subroutine ESMF_AlarmGetPrevRingTime(alarm, PrevRingTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + type(ESMF_Time), intent(out) :: PrevRingTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Alarm}'s previous ring time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to get the previous ring time +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.7, TMG4.8 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + PrevRingTime = alarm%alarmint%PrevRingTime + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmGetPrevRingTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmSetPrevRingTime - Set an alarm's previous ring time +! +! !INTERFACE: + subroutine ESMF_AlarmSetPrevRingTime(alarm, PrevRingTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(out) :: alarm + type(ESMF_Time), intent(in) :: PrevRingTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Alarm}'s previous ring time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to set the previous ring time +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time to set +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.7, TMG4.8 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmSetPrevRingTime not supported' ) + end subroutine ESMF_AlarmSetPrevRingTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmGetStopTime - Get an alarm's stop time +! +! !INTERFACE: + subroutine ESMF_AlarmGetStopTime(alarm, StopTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + type(ESMF_Time), intent(out) :: StopTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Alarm}'s stop time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to get the stop time +! \item[StopTime] +! The {\tt ESMF\_Alarm}'s stop time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.5.2, TMG4.7 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmGetStopTime not supported' ) + end subroutine ESMF_AlarmGetStopTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmSetStopTime - Set an alarm's stop time +! +! !INTERFACE: + subroutine ESMF_AlarmSetStopTime(alarm, StopTime, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(out) :: alarm + type(ESMF_Time), intent(in) :: StopTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Alarm}'s stop time +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to set the stop time +! \item[StopTime] +! The {\tt ESMF\_Alarm}'s stop time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.5.2, TMG4.7 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmSetStopTime not supported' ) + end subroutine ESMF_AlarmSetStopTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmEnable - Enables an alarm + +! !INTERFACE: + subroutine ESMF_AlarmEnable(alarm, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Enables an {\tt ESMF\_Alarm} to function +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to enable +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.5.3 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + alarm%alarmint%Enabled = .TRUE. + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmEnable + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmDisable - Disables an alarm + +! !INTERFACE: + subroutine ESMF_AlarmDisable(alarm, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Disables an {\tt ESMF\_Alarm} +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to disable +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.5.3 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + alarm%alarmint%Enabled = .FALSE. + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmDisable + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmRingerOn - Turn on an alarm + + +! !INTERFACE: + subroutine ESMF_AlarmRingerOn(alarm, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Turn on an {\tt ESMF\_Alarm}; sets ringing state +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to turn on +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.6 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%Enabled ) THEN + alarm%alarmint%Ringing = .TRUE. + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + alarm%alarmint%Ringing = .FALSE. + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + + end subroutine ESMF_AlarmRingerOn + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmRingerOff - Turn off an alarm + +! !INTERFACE: + subroutine ESMF_AlarmRingerOff(alarm, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Turn off an {\tt ESMF\_Alarm}; unsets ringing state +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to turn off +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.6 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + alarm%alarmint%Ringing = .FALSE. + IF ( alarm%alarmint%Enabled ) THEN + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end subroutine ESMF_AlarmRingerOff + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmIsRinging - Check if alarm is ringing + +! !INTERFACE: + function ESMF_AlarmIsRinging(alarm, rc) +! +! !RETURN VALUE: + logical :: ESMF_AlarmIsRinging + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Check if {\tt ESMF\_Alarm} is ringing. +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to check for ringing state +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.4 +!EOP + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%Enabled ) THEN + ESMF_AlarmIsRinging = alarm%alarmint%Ringing + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + ELSE + ESMF_AlarmIsRinging = .FALSE. + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + ELSE + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ENDIF + end function ESMF_AlarmIsRinging + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmCheckRingTime - Method used by a clock to check whether to trigger an alarm +! +! !INTERFACE: + function ESMF_AlarmCheckRingTime(alarm, ClockCurrTime, positive, rc) +! +! !RETURN VALUE: + logical :: ESMF_AlarmCheckRingTime +! +! !ARGUMENTS: + type(ESMF_Alarm), intent(inout) :: alarm + type(ESMF_Time), intent(in) :: ClockCurrTime + integer, intent(in) :: positive + integer, intent(out), optional :: rc +! +! !DESCRIPTION: +! Main method used by a {\tt ESMF\_Clock} to check whether to trigger +! the {\tt ESMF\_Alarm} +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to check if time to ring +! \item[ClockCurrTime] +! The {\tt ESMF\_Clock}'s current time +! \item[positive] +! Whether to check ring time in the positive or negative direction +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG4.4, TMG4.6 +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmCheckRingTime not supported' ) + ESMF_AlarmCheckRingTime = .FALSE. ! keep compilers happy + end function ESMF_AlarmCheckRingTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmEQ - Compare two alarms for equality +! +! !INTERFACE: + function ESMF_AlarmEQ(alarm1, alarm2) +! +! !RETURN VALUE: + logical :: ESMF_AlarmEQ + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm1 + type(ESMF_Alarm), intent(in) :: alarm2 + +! !DESCRIPTION: +! Compare two alarms for equality; return true if equal, false otherwise +! Maps to overloaded (==) operator interface function +! +! The arguments are: +! \begin{description} +! \item[alarm1] +! The first {\tt ESMF\_Alarm} to compare +! \item[alarm2] +! The second {\tt ESMF\_Alarm} to compare +! \end{description} +! +! !REQUIREMENTS: +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmEQ not supported ' ) + ESMF_AlarmEQ = .FALSE. ! keep compilers happy + end function ESMF_AlarmEQ + +!------------------------------------------------------------------------------ +! +! This section defines the overridden Read, Write, Validate and Print methods +! from the ESMF_Base class +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmRead - restores an alarm + +! !INTERFACE: + subroutine ESMF_AlarmRead(alarm, RingInterval, RingTime, & + PrevRingTime, StopTime, Ringing, & + Enabled, ID, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(out) :: alarm + type(ESMF_TimeInterval), intent(in) :: RingInterval + type(ESMF_Time), intent(in) :: RingTime + type(ESMF_Time), intent(in) :: PrevRingTime + type(ESMF_Time), intent(in) :: StopTime + logical, intent(in) :: Ringing + logical, intent(in) :: Enabled + integer, intent(in) :: ID + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Restores an {\tt ESMF\_Alarm} +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to restore +! \item[RingInterval] +! The ring interval for repeating alarms +! \item[RingTime] +! Ring time for one-shot or first repeating alarm +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time +! \item[StopTime] +! Stop time for repeating alarms +! \item[Ringing] +! The {\tt ESMF\_Alarm}'s ringing state +! \item[Enabled] +! {\tt ESMF\_Alarm} enabled/disabled +! \item[ID] +! The {\tt ESMF\_Alarm}'s ID +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmRead not supported' ) + end subroutine ESMF_AlarmRead + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmWrite - saves an alarm + +! !INTERFACE: + subroutine ESMF_AlarmWrite(alarm, RingInterval, RingTime, & + PrevRingTime, StopTime, Ringing, & + Enabled, ID, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + type(ESMF_TimeInterval), intent(out) :: RingInterval + type(ESMF_Time), intent(out) :: RingTime + type(ESMF_Time), intent(out) :: PrevRingTime + type(ESMF_Time), intent(out) :: StopTime + logical, intent(out) :: Ringing + logical, intent(out) :: Enabled + integer, intent(out) :: ID + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Saves an {\tt ESMF\_Alarm} +! +! The arguments are: +! \begin{description} +! \item[alarm] +! The object instance to save +! \item[RingInterval] +! Ring interval for repeating alarms +! \item[RingTime] +! Ring time for one-shot or first repeating alarm +! \item[PrevRingTime] +! The {\tt ESMF\_Alarm}'s previous ring time +! \item[StopTime] +! Stop time for repeating alarms +! \item[Ringing] +! The {\tt ESMF\_Alarm}'s ringing state +! \item[Enabled] +! {\tt ESMF\_Alarm} enabled/disabled +! \item[ID] +! The {\tt ESMF\_Alarm}'s ID +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmWrite not supported' ) + end subroutine ESMF_AlarmWrite + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmValidate - Validate an Alarm's properties + +! !INTERFACE: + subroutine ESMF_AlarmValidate(alarm, opts, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Perform a validation check on a {\tt ESMF\_Alarm}'s properties +! +! The arguments are: +! \begin{description} +! \item[alarm] +! {\tt ESMF\_Alarm} to validate +! \item[{[opts]}] +! Validate options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + CALL wrf_error_fatal( 'ESMF_AlarmValidate not supported' ) + end subroutine ESMF_AlarmValidate + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_AlarmPrint - Print out an Alarm's properties + +! !INTERFACE: + subroutine ESMF_AlarmPrint(alarm, opts, rc) + +! !ARGUMENTS: + type(ESMF_Alarm), intent(in) :: alarm + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! To support testing/debugging, print out a {\tt ESMF\_Alarm}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[alarm] +! {\tt ESMF\_Alarm} to print out +! \item[{[opts]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + integer :: ierr + type(ESMF_Time) :: ringtime + type(ESMF_Time) :: prevringtime + type(ESMF_TimeInterval) :: ringinterval + character(len=256) :: name + + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%RingTimeSet )THEN + call ESMF_AlarmGet( alarm, name=name, ringtime=ringtime, & + prevringtime=prevringtime, rc=ierr ) + IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + END IF + print *, 'Alarm name: ', trim(name) + print *, 'Next ring time' + call ESMF_TimePrint( ringtime ) + print *, 'Previous ring time' + call ESMF_TimePrint( prevringtime ) + END IF + IF ( alarm%alarmint%RingIntervalSet )THEN + call ESMF_AlarmGet( alarm, ringinterval=ringinterval, rc=ierr ) + IF ( PRESENT(rc) .AND. (ierr /= ESMF_SUCCESS) )THEN + rc = ierr + END IF + print *, 'Ring Interval' + call ESMF_TimeIntervalPrint( ringinterval ) + END IF + END IF + + end subroutine ESMF_AlarmPrint + +!------------------------------------------------------------------------------ + + end module ESMF_AlarmMod diff --git a/share/esmf_wrf_timemgr/ESMF_BaseMod.F90 b/share/esmf_wrf_timemgr/ESMF_BaseMod.F90 new file mode 100644 index 000000000000..ad867122dd7c --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_BaseMod.F90 @@ -0,0 +1,1089 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +! ESMF Base Module +! +! (all lines between the !BOP and !EOP markers will be included in the +! automated document processing.) +!------------------------------------------------------------------------------ + +!------------------------------------------------------------------------------ +! module definition + + module ESMF_BaseMod + +!BOP +! !MODULE: ESMF_BaseMod - Base class for all ESMF classes +! +! !DESCRIPTION: +! +! The code in this file implements the Base defined type +! and functions which operate on all types. This is an +! interface to the actual C++ base class implementation in the ../src dir. +! +! See the ESMF Developers Guide document for more details. +! +!------------------------------------------------------------------------------ + +! !USES: + implicit none +! +! !PRIVATE TYPES: + private + +!------------------------------------------------------------------------------ +! +! Global integer parameters, used frequently + + integer, parameter :: ESMF_SUCCESS = 0, ESMF_FAILURE = -1 + integer, parameter :: ESMF_MAXSTR = 128 + integer, parameter :: ESMF_MAXDIM = 7, & + ESMF_MAXDECOMPDIM=3, & + ESMF_MAXGRIDDIM=2 + + integer, parameter :: ESMF_MAJOR_VERSION = 2 + integer, parameter :: ESMF_MINOR_VERSION = 2 + integer, parameter :: ESMF_REVISION = 3 + integer, parameter :: ESMF_PATCHLEVEL = 0 + character(32), parameter :: ESMF_VERSION_STRING = "2.2.3" + +!------------------------------------------------------------------------------ +! + type ESMF_Status + private + integer :: status + end type + + type(ESMF_Status), parameter :: ESMF_STATE_UNINIT = ESMF_Status(1), & + ESMF_STATE_READY = ESMF_Status(2), & + ESMF_STATE_UNALLOCATED = ESMF_Status(3), & + ESMF_STATE_ALLOCATED = ESMF_Status(4), & + ESMF_STATE_BUSY = ESMF_Status(5), & + ESMF_STATE_INVALID = ESMF_Status(6) + +!------------------------------------------------------------------------------ +! + type ESMF_Pointer + private + integer*8 :: ptr + end type + + type(ESMF_Pointer), parameter :: ESMF_NULL_POINTER = ESMF_Pointer(0), & + ESMF_BAD_POINTER = ESMF_Pointer(-1) + + +!------------------------------------------------------------------------------ +! + !! TODO: I believe if we define an assignment(=) operator to convert + !! a datatype into integer, then we could use the type and kind as + !! targets in a select case() statement and make the contents private. + !! (see pg 248 of the "big book") + type ESMF_DataType + !!private + integer :: dtype + end type + + type(ESMF_DataType), parameter :: ESMF_DATA_INTEGER = ESMF_DataType(1), & + ESMF_DATA_REAL = ESMF_DataType(2), & + ESMF_DATA_LOGICAL = ESMF_DataType(3), & + ESMF_DATA_CHARACTER = ESMF_DataType(4) + +!------------------------------------------------------------------------------ + + integer, parameter :: & + ESMF_KIND_I1 = selected_int_kind(2), & + ESMF_KIND_I2 = selected_int_kind(4), & + ESMF_KIND_I4 = selected_int_kind(9), & + ESMF_KIND_I8 = selected_int_kind(18), & + ESMF_KIND_R4 = selected_real_kind(3,25), & + ESMF_KIND_R8 = selected_real_kind(6,45), & + ESMF_KIND_C8 = selected_real_kind(3,25), & + ESMF_KIND_C16 = selected_real_kind(6,45) + +!------------------------------------------------------------------------------ + + type ESMF_DataValue + private + type(ESMF_DataType) :: dt + integer :: rank + ! how do you do values of all types here ? TODO + ! in C++ i'd do a union w/ overloaded access funcs + integer :: vi + !integer, dimension (:), pointer :: vip + !real :: vr + !real, dimension (:), pointer :: vrp + !logical :: vl + !logical, pointer :: vlp + !character (len=ESMF_MAXSTR) :: vc + !character, pointer :: vcp + end type + +!------------------------------------------------------------------------------ +! + type ESMF_Attribute + private + character (len=ESMF_MAXSTR) :: attr_name + type (ESMF_DataType) :: attr_type + type (ESMF_DataValue) :: attr_value + end type + +!------------------------------------------------------------------------------ +! + !! TODO: this should be a shallow object, with a simple init() and + !! get() function, and the contents should go back to being private. + type ESMF_AxisIndex +! !!private + integer :: l + integer :: r + integer :: max + integer :: decomp + integer :: gstart + end type + + !! TODO: same comment as above. + type ESMF_MemIndex +! !!private + integer :: l + integer :: r + integer :: str + integer :: num + end type + +!------------------------------------------------------------------------------ +! + type ESMF_BasePointer + private + integer*8 :: base_ptr + end type + + integer :: global_count = 0 + +!------------------------------------------------------------------------------ +! +! ! WARNING: must match corresponding values in ../include/ESMC_Base.h + type ESMF_Logical + private + integer :: value + end type + + type(ESMF_Logical), parameter :: ESMF_TF_UNKNOWN = ESMF_Logical(1), & + ESMF_TF_TRUE = ESMF_Logical(2), & + ESMF_TF_FALSE = ESMF_Logical(3) + +!------------------------------------------------------------------------------ +! + type ESMF_Base + private + integer :: ID + integer :: ref_count + type (ESMF_Status) :: base_status + character (len=ESMF_MAXSTR) :: name + end type + +! !PUBLIC TYPES: + + public ESMF_STATE_INVALID +! public ESMF_STATE_UNINIT, ESMF_STATE_READY, & +! ESMF_STATE_UNALLOCATED, ESMF_STATE_ALLOCATED, & +! ESMF_STATE_BUSY + + public ESMF_DATA_INTEGER, ESMF_DATA_REAL, & + ESMF_DATA_LOGICAL, ESMF_DATA_CHARACTER + + public ESMF_KIND_I1, ESMF_KIND_I2, ESMF_KIND_I4, ESMF_KIND_I8, & + ESMF_KIND_R4, ESMF_KIND_R8, ESMF_KIND_C8, ESMF_KIND_C16 + + public ESMF_NULL_POINTER, ESMF_BAD_POINTER + + + public ESMF_FAILURE, ESMF_SUCCESS + public ESMF_MAXSTR + public ESMF_MAXDIM, ESMF_MAXDECOMPDIM, ESMF_MAXGRIDDIM + + public ESMF_MAJOR_VERSION, ESMF_MINOR_VERSION, ESMF_REVISION + public ESMF_VERSION_STRING + + public ESMF_Status, ESMF_Pointer, ESMF_DataType + public ESMF_DataValue, ESMF_Attribute +! public ESMF_MemIndex +! public ESMF_BasePointer + public ESMF_Base + + public ESMF_AxisIndex, ESMF_AxisIndexGet +! public ESMF_AxisIndexInit + public ESMF_Logical +! public ESMF_TF_TRUE, ESMF_TF_FALSE + +! !PUBLIC MEMBER FUNCTIONS: +! +! !DESCRIPTION: +! The following routines apply to any type in the system. +! The attribute routines can be inherited as-is. The other +! routines need to be specialized by the higher level objects. +! +! Base class methods +! public ESMF_BaseInit + +! public ESMF_BaseGetConfig +! public ESMF_BaseSetConfig + +! public ESMF_BaseGetInstCount + +! public ESMF_BaseSetID +! public ESMF_BaseGetID + +! public ESMF_BaseSetRefCount +! public ESMF_BaseGetRefCount + +! public ESMF_BaseSetStatus +! public ESMF_BaseGetStatus + +! Virtual methods to be defined by derived classes +! public ESMF_Read +! public ESMF_Write +! public ESMF_Validate +! public ESMF_Print + +! Attribute methods + public ESMF_AttributeSet + public ESMF_AttributeGet + public ESMF_AttributeGetCount + public ESMF_AttributeGetbyNumber + public ESMF_AttributeGetNameList + public ESMF_AttributeSetList + public ESMF_AttributeGetList + public ESMF_AttributeSetObjectList + public ESMF_AttributeGetObjectList + public ESMF_AttributeCopy + public ESMF_AttributeCopyAll + +! Misc methods + public ESMF_SetName + public ESMF_GetName + public ESMF_SetPointer + public ESMF_SetNullPointer + public ESMF_GetPointer + +! Print methods for calling by higher level print functions +! (they have little formatting other than the actual values) + public ESMF_StatusString, ESMF_DataTypeString + +! Overloaded = operator functions + public operator(.eq.), operator(.ne.), assignment(=) +! +! +!EOP + +!------------------------------------------------------------------------------ +! leave the following line as-is; it will insert the cvs ident string +! into the object file for tracking purposes. + character(*), parameter, private :: version = & + '$Id$' +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ + +! overload .eq. & .ne. with additional derived types so you can compare +! them as if they were simple integers. + + +interface operator (.eq.) + module procedure ESMF_sfeq + module procedure ESMF_dteq + module procedure ESMF_pteq + module procedure ESMF_tfeq + module procedure ESMF_aieq +end interface + +interface operator (.ne.) + module procedure ESMF_sfne + module procedure ESMF_dtne + module procedure ESMF_ptne + module procedure ESMF_tfne + module procedure ESMF_aine +end interface + +interface assignment (=) + module procedure ESMF_dtas + module procedure ESMF_ptas +end interface + +!------------------------------------------------------------------------------ + + contains + +!------------------------------------------------------------------------------ +! function to compare two ESMF_Status flags to see if they're the same or not + +function ESMF_sfeq(sf1, sf2) + logical ESMF_sfeq + type(ESMF_Status), intent(in) :: sf1, sf2 + + ESMF_sfeq = (sf1%status .eq. sf2%status) +end function + +function ESMF_sfne(sf1, sf2) + logical ESMF_sfne + type(ESMF_Status), intent(in) :: sf1, sf2 + + ESMF_sfne = (sf1%status .ne. sf2%status) +end function + +!------------------------------------------------------------------------------ +! function to compare two ESMF_DataTypes to see if they're the same or not + +function ESMF_dteq(dt1, dt2) + logical ESMF_dteq + type(ESMF_DataType), intent(in) :: dt1, dt2 + + ESMF_dteq = (dt1%dtype .eq. dt2%dtype) +end function + +function ESMF_dtne(dt1, dt2) + logical ESMF_dtne + type(ESMF_DataType), intent(in) :: dt1, dt2 + + ESMF_dtne = (dt1%dtype .ne. dt2%dtype) +end function + +subroutine ESMF_dtas(intval, dtval) + integer, intent(out) :: intval + type(ESMF_DataType), intent(in) :: dtval + + intval = dtval%dtype +end subroutine + + +!------------------------------------------------------------------------------ +! function to compare two ESMF_Pointers to see if they're the same or not + +function ESMF_pteq(pt1, pt2) + logical ESMF_pteq + type(ESMF_Pointer), intent(in) :: pt1, pt2 + + ESMF_pteq = (pt1%ptr .eq. pt2%ptr) +end function + +function ESMF_ptne(pt1, pt2) + logical ESMF_ptne + type(ESMF_Pointer), intent(in) :: pt1, pt2 + + ESMF_ptne = (pt1%ptr .ne. pt2%ptr) +end function + +subroutine ESMF_ptas(ptval, intval) + type(ESMF_Pointer), intent(out) :: ptval + integer, intent(in) :: intval + + ptval%ptr = intval +end subroutine + +!------------------------------------------------------------------------------ +! function to compare two ESMF_Logicals to see if they're the same or not +! also need assignment to real f90 logical? + +function ESMF_tfeq(tf1, tf2) + logical ESMF_tfeq + type(ESMF_Logical), intent(in) :: tf1, tf2 + + ESMF_tfeq = (tf1%value .eq. tf2%value) +end function + +function ESMF_tfne(tf1, tf2) + logical ESMF_tfne + type(ESMF_Logical), intent(in) :: tf1, tf2 + + ESMF_tfne = (tf1%value .ne. tf2%value) +end function + +!------------------------------------------------------------------------------ +! function to compare two ESMF_AxisIndex to see if they're the same or not + +function ESMF_aieq(ai1, ai2) + logical ESMF_aieq + type(ESMF_AxisIndex), intent(in) :: ai1, ai2 + + ESMF_aieq = ((ai1%l .eq. ai2%l) .and. & + (ai1%r .eq. ai2%r) .and. & + (ai1%max .eq. ai2%max) .and. & + (ai1%decomp .eq. ai2%decomp) .and. & + (ai1%gstart .eq. ai2%gstart)) + +end function + +function ESMF_aine(ai1, ai2) + logical ESMF_aine + type(ESMF_AxisIndex), intent(in) :: ai1, ai2 + + ESMF_aine = ((ai1%l .ne. ai2%l) .or. & + (ai1%r .ne. ai2%r) .or. & + (ai1%max .ne. ai2%max) .or. & + (ai1%decomp .ne. ai2%decomp) .or. & + (ai1%gstart .ne. ai2%gstart)) + +end function + +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +! +! Base methods +! +!------------------------------------------------------------------------------ +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_BaseInit - initialize a Base object +! +! !INTERFACE: + subroutine ESMF_BaseInit(base, rc) +! +! !ARGUMENTS: + type(ESMF_Base) :: base + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Set initial state on a Base object. +! +! \begin{description} +! \item [base] +! In the Fortran interface, this must in fact be a {\tt Base} +! derived type object. It is expected that all specialized +! derived types will include a {\tt Base} object as the first +! entry. +! \item [{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! +! \end{description} +! +!EOP + + logical :: rcpresent ! Return code present + +! !Initialize return code + rcpresent = .FALSE. + if(present(rc)) then + rcpresent = .TRUE. + rc = ESMF_FAILURE + endif + + global_count = global_count + 1 + base%ID = global_count + base%ref_count = 1 + base%base_status = ESMF_STATE_READY + base%name = "undefined" + + if (rcpresent) rc = ESMF_SUCCESS + + end subroutine ESMF_BaseInit + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_SetName - set the name of this object +! +! !INTERFACE: + subroutine ESMF_SetName(anytype, name, namespace, rc) +! +! !ARGUMENTS: + type(ESMF_Base) :: anytype + character (len = *), intent(in), optional :: name + character (len = *), intent(in), optional :: namespace + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Associate a name with any object in the system. +! +! \begin{description} +! \item [anytype] +! In the Fortran interface, this must in fact be a {\tt Base} +! derived type object. It is expected that all specialized +! derived types will include a {\tt Base} object as the first +! entry. +! \item [[name]] +! Object name. An error will be returned if a duplicate name +! is specified. If a name is not given a unique name will be +! generated and can be queried by the {\tt ESMF_GetName} routine. +! \item [[namespace]] +! Object namespace (e.g. "Application", "Component", "Grid", etc). +! If given, the name will be checked that it is unique within +! this namespace. If not given, the generated name will be +! unique within this namespace. If namespace is not specified, +! a default "global" namespace will be assumed and the same rules +! for names will be followed. +! \item [[rc]] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! +! \end{description} +! +! + +! +!EOP +! !REQUIREMENTS: FLD1.5, FLD1.5.3 + logical :: rcpresent ! Return code present + character (len = ESMF_MAXSTR) :: ournamespace ! Namespace if not given + character (len = ESMF_MAXSTR) :: defaultname ! Name if not given + integer, save :: seqnum = 0 ! HACK - generate uniq names + ! but not coordinated across procs + +! !Initialize return code + rcpresent = .FALSE. + if(present(rc)) then + rcpresent = .TRUE. + rc = ESMF_FAILURE + endif + +! ! TODO: this code should generate a unique name if a name +! ! is not given. If a namespace is given, the name has to +! ! be unique within that namespace. Example namespaces could +! ! be: Applications, Components, Fields/Bundles, Grids. +! +! ! Construct a default namespace if one is not given + if((.not. present(namespace)) .or. (namespace .eq. "")) then + ournamespace = "global" + else + ournamespace = namespace + endif +! ! Construct a default name if one is not given + if((.not. present(name)) .or. (name .eq. "")) then + + write(defaultname, 20) trim(ournamespace), seqnum +20 format(A,I3.3) + seqnum = seqnum + 1 + anytype%name = defaultname + else + anytype%name = name + endif + + if (rcpresent) rc = ESMF_SUCCESS + + end subroutine ESMF_SetName + +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_GetName - get the name of this object +! +! !INTERFACE: + subroutine ESMF_GetName(anytype, name, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF object/type + character (len = *), intent(out) :: name ! object/type name + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Return the name of any type in the system. + +! +!EOP +! !REQUIREMENTS: FLD1.5, FLD1.5.3 + + name = anytype%name + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_GetName + + +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_AttributeSet - set attribute on an ESMF type +! +! !INTERFACE: + subroutine ESMF_AttributeSet(anytype, name, value, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + character (len = *), intent(in) :: name ! attribute name + type(ESMF_DataValue), intent(in) :: value ! attribute value + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Associate a (name,value) pair with any type in the system. + +! +!EOP +! !REQUIREMENTS: FLD1.5, FLD1.5.3 + + end subroutine ESMF_AttributeSet + + +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_AttributeGet - get attribute from an ESMF type +! +! !INTERFACE: + subroutine ESMF_AttributeGet(anytype, name, type, value, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + character (len = *), intent(in) :: name ! attribute name + type(ESMF_DataType), intent(out) :: type ! all possible data types + type(ESMF_DataValue), intent(out) :: value ! attribute value + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: + +! +!EOP +! !REQUIREMENTS: FLD1.5.1, FLD1.5.3 + + end subroutine ESMF_AttributeGet + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeGetCount - get an ESMF object's number of attributes +! +! !INTERFACE: + subroutine ESMF_AttributeGetCount(anytype, count, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + integer, intent(out) :: count ! attribute count + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Returns number of attributes present. + +! +!EOP +! !REQUIREMENTS: FLD1.7.5 + + end subroutine ESMF_AttributeGetCount + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeGetbyNumber - get an ESMF object's attribute by num ber +! +! !INTERFACE: + subroutine ESMF_AttributeGetbyNumber(anytype, number, name, type, value, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + integer, intent(in) :: number ! attribute number + character (len = *), intent(in) :: name ! attribute name + type(ESMF_DataType), intent(out) :: type ! all possible data types + type(ESMF_DataValue), intent(out) :: value ! attribute value + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Allows the caller to get attributes by number instead of by name. +! This can be useful in iterating through all attributes in a loop. +! +!EOP +! !REQUIREMENTS: + + end subroutine ESMF_AttributeGetbyNumber + + +!------------------------------------------------------------------------- +!BOP +! +!IROUTINE: ESMF_AttributeGetNameList - get an ESMF object's attribute name list +! +! !INTERFACE: + subroutine ESMF_AttributeGetNameList(anytype, count, namelist, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + integer, intent(out) :: count ! attribute count + character (len = *), dimension (:), intent(out) :: namelist ! attribute names + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Return a list of all attribute names without returning the values. + +! +!EOP +! !REQUIREMENTS: FLD1.7.3 + + end subroutine ESMF_AttributeGetNameList + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeSetList - set an ESMF object's attributes +! +! !INTERFACE: + subroutine ESMF_AttributeSetList(anytype, namelist, valuelist, rc) + +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + character (len = *), dimension (:), intent(in) :: namelist ! attribute names + type(ESMF_DataValue), dimension (:), intent(in) :: valuelist ! attribute values + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Set multiple attributes on an object in one call. Depending on what is +! allowed by the interface, all attributes may have to have the same type. +! +!EOP +! !REQUIREMENTS: (none. added for completeness) + + end subroutine ESMF_AttributeSetList + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeGetList - get an ESMF object's attributes +! +! !INTERFACE: + subroutine ESMF_AttributeGetList(anytype, namelist, typelist, valuelist, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: anytype ! any ESMF type + character (len = *), dimension (:), intent(in) :: namelist ! attribute names + type(ESMF_DataType), dimension (:), intent(out) :: typelist ! all possible data types + type(ESMF_DataValue), dimension (:), intent(out) :: valuelist ! attribute values + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Get multiple attributes from an object in a single call. + +! +!EOP +! !REQUIREMENTS: FLD1.7.4 + + end subroutine ESMF_AttributeGetList + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeSetObjectList - set an attribute on multiple ESMF objects +! +! !INTERFACE: + subroutine ESMF_AttributeSetObjectList(anytypelist, name, value, rc) +! +! !ARGUMENTS: + type(ESMF_Base), dimension (:), intent(in) :: anytypelist ! list of any ESMF types + character (len = *), intent(in) :: name ! attribute name + type(ESMF_DataValue), dimension (:), intent(in) :: value ! attribute value + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Set the same attribute on multiple objects in one call. + +! +!EOP +! !REQUIREMENTS: FLD1.5.5 (pri 2) + + end subroutine ESMF_AttributeSetObjectList + + +!------------------------------------------------------------------------- +!BOP +! +! +! !IROUTINE: ESMF_AttributeGetObjectList - get an attribute from multiple ESMF objects +! +! !INTERFACE: + subroutine ESMF_AttributeGetObjectList(anytypelist, name, typelist, valuelist, rc) +! +! !ARGUMENTS: + type(ESMF_Base), dimension (:), intent(in) :: anytypelist ! list of any ESMF types + character (len = *), intent(in) :: name ! attribute name + type(ESMF_DataType), dimension (:), intent(out) :: typelist ! all possible data types + type(ESMF_DataValue), dimension (:), intent(out) :: valuelist ! attribute values + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! Get the same attribute name from multiple objects in one call. + +! +!EOP +! !REQUIREMENTS: FLD1.5.5 (pri 2) + + end subroutine ESMF_AttributeGetObjectList + + +!------------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ESMF_AttributeCopy - copy an attribute between two objects +! +! !INTERFACE: + subroutine ESMF_AttributeCopy(name, source, destination, rc) +! +! !ARGUMENTS: + character (len = *), intent(in) :: name ! attribute name + type(ESMF_Base), intent(in) :: source ! any ESMF type + type(ESMF_Base), intent(in) :: destination ! any ESMF type + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! The specified attribute associated with the source object is +! copied to the destination object. << does this assume overwriting the +! attribute if it already exists in the output or does this require yet +! another arg to say what to do with collisions? >> + + +! +!EOP +! !REQUIREMENTS: FLD1.5.4 + + end subroutine ESMF_AttributeCopy + + +!------------------------------------------------------------------------- +!BOP +! +!IROUTINE: ESMC_AttributeCopyAll - copy attributes between two objects + +! +! !INTERFACE: + subroutine ESMF_AttributeCopyAll(source, destination, rc) +! +! !ARGUMENTS: + type(ESMF_Base), intent(in) :: source ! any ESMF type + type(ESMF_Base), intent(in) :: destination ! any ESMF type + integer, intent(out), optional :: rc ! return code + +! +! !DESCRIPTION: +! All attributes associated with the source object are copied to the +! destination object. Some attributes will have to be considered +! {\tt read only} and won't be updated by this call. (e.g. an attribute +! like {\tt name} must be unique and therefore can't be duplicated.) + +! +!EOP +! !REQUIREMENTS: FLD1.5.4 + + end subroutine ESMF_AttributeCopyAll + +!========================================================================= +! Misc utility routines, perhaps belongs in a utility file? +!------------------------------------------------------------------------- +!BOP +! +!IROUTINE: ESMC_AxisIndexInit - initialize an AxisIndex object + +! +! !INTERFACE: + subroutine ESMF_AxisIndexInit(ai, l, r, max, decomp, gstart, rc) +! +! !ARGUMENTS: + type(ESMF_AxisIndex), intent(inout) :: ai + integer, intent(in) :: l, r, max, decomp, gstart + integer, intent(out), optional :: rc +! +! !DESCRIPTION: +! Set the contents of an AxisIndex type. + +! +!EOP +! !REQUIREMENTS: + + ai%l = l + ai%r = r + ai%max = max + ai%decomp = decomp + ai%gstart = gstart + + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_AxisIndexInit + +!BOP +! +!IROUTINE: ESMC_AxisIndexInit - initialize an AxisIndex object + +! +! !INTERFACE: + subroutine ESMF_AxisIndexGet(ai, l, r, max, decomp, gstart, rc) +! +! !ARGUMENTS: + type(ESMF_AxisIndex), intent(inout) :: ai + integer, intent(out), optional :: l, r, max, decomp, gstart + integer, intent(out), optional :: rc +! +! !DESCRIPTION: +! Get the contents of an AxisIndex type. + +! +!EOP +! !REQUIREMENTS: + + if (present(l)) l = ai%l + if (present(r)) r = ai%r + if (present(max)) max = ai%max + if (present(decomp)) decomp = ai%decomp + if (present(gstart)) gstart = ai%gstart + + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_AxisIndexGet + +!------------------------------------------------------------------------- +!------------------------------------------------------------------------- +!BOP +! +!IROUTINE: ESMF_SetPointer - set an opaque value + +! +! !INTERFACE: + subroutine ESMF_SetPointer(ptype, contents, rc) +! +! !ARGUMENTS: + type(ESMF_Pointer) :: ptype + integer*8, intent(in) :: contents + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Set the contents of an opaque pointer type. + +! +!EOP +! !REQUIREMENTS: + ptype%ptr = contents + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_SetPointer + +!------------------------------------------------------------------------- +!BOP +! +!IROUTINE: ESMF_SetNullPointer - set an opaque value + +! +! !INTERFACE: + subroutine ESMF_SetNullPointer(ptype, rc) +! +! !ARGUMENTS: + type(ESMF_Pointer) :: ptype + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Set the contents of an opaque pointer type. + +! +!EOP +! !REQUIREMENTS: + integer*8, parameter :: nullp = 0 + + ptype%ptr = nullp + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_SetNullPointer +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_GetPointer - get an opaque value +! +! !INTERFACE: + function ESMF_GetPointer(ptype, rc) +! +! !RETURN VALUE: + integer*8 :: ESMF_GetPointer + +! !ARGUMENTS: + type(ESMF_Pointer), intent(in) :: ptype + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Get the contents of an opaque pointer type. + +! +!EOP +! !REQUIREMENTS: + ESMF_GetPointer = ptype%ptr + if (present(rc)) rc = ESMF_SUCCESS + + end function ESMF_GetPointer + +!------------------------------------------------------------------------- +! misc print routines +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_StatusString - Return status as a string +! +! !INTERFACE: + subroutine ESMF_StatusString(status, string, rc) +! +! !ARGUMENTS: + type(ESMF_Status), intent(in) :: status + character(len=*), intent(out) :: string + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Return a status variable as a string. + +! +!EOP +! !REQUIREMENTS: + + if (status .eq. ESMF_STATE_UNINIT) string = "Uninitialized" + if (status .eq. ESMF_STATE_READY) string = "Ready" + if (status .eq. ESMF_STATE_UNALLOCATED) string = "Unallocated" + if (status .eq. ESMF_STATE_ALLOCATED) string = "Allocated" + if (status .eq. ESMF_STATE_BUSY) string = "Busy" + if (status .eq. ESMF_STATE_INVALID) string = "Invalid" + + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_StatusString + +!------------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_DataTypeString - Return DataType as a string +! +! !INTERFACE: + subroutine ESMF_DataTypeString(datatype, string, rc) +! +! !ARGUMENTS: + type(ESMF_DataType), intent(in) :: datatype + character(len=*), intent(out) :: string + integer, intent(out), optional :: rc + +! +! !DESCRIPTION: +! Return a datatype variable as a string. + +! +!EOP +! !REQUIREMENTS: + + if (datatype .eq. ESMF_DATA_INTEGER) string = "Integer" + if (datatype .eq. ESMF_DATA_REAL) string = "Real" + if (datatype .eq. ESMF_DATA_LOGICAL) string = "Logical" + if (datatype .eq. ESMF_DATA_CHARACTER) string = "Character" + + if (present(rc)) rc = ESMF_SUCCESS + + end subroutine ESMF_DataTypeString + +!------------------------------------------------------------------------- +! +!------------------------------------------------------------------------- +! put Print and Validate skeletons here - but they should be +! overridden by higher level more specialized functions. +!------------------------------------------------------------------------- + + end module ESMF_BaseMod diff --git a/share/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 b/share/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 new file mode 100644 index 000000000000..6eb4573afebc --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_BaseTimeMod.F90 @@ -0,0 +1,461 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF BaseTime Module + module ESMF_BaseTimeMod +! +!============================================================================== +! +! This file contains the BaseTime class definition and all BaseTime class +! methods. +! +!------------------------------------------------------------------------------ +! INCLUDES + +#include +! +!=============================================================================== +!BOPI +! !MODULE: ESMF_BaseTimeMod - Base ESMF time definition +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! This module serves only as the common Time definition inherited +! by {\tt ESMF\_TimeInterval} and {\tt ESMF\_Time} +! +! See {\tt ../include/ESMC\_BaseTime.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + use ESMF_BaseMod ! ESMF Base class + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_BaseTime +! +! ! Base class type to match C++ BaseTime class in size only; +! ! all dereferencing within class is performed by C++ implementation + + type ESMF_BaseTime + integer(ESMF_KIND_I8) :: S ! whole seconds + integer(ESMF_KIND_I8) :: Sn ! fractional seconds, numerator + integer(ESMF_KIND_I8) :: Sd ! fractional seconds, denominator + end type + +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_BaseTime +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: +! +! overloaded operators + public seccmp + public normalize_basetime + public operator(+) + private ESMF_BaseTimeSum + public operator(-) + private ESMF_BaseTimeDifference + public operator(/) + private ESMF_BaseTimeQuotI + private ESMF_BaseTimeQuotI8 + public operator(.EQ.) + private ESMF_BaseTimeEQ + public operator(.NE.) + private ESMF_BaseTimeNE + public operator(.LT.) + private ESMF_BaseTimeLT + public operator(.GT.) + private ESMF_BaseTimeGT + public operator(.LE.) + private ESMF_BaseTimeLE + public operator(.GE.) + private ESMF_BaseTimeGE + +!============================================================================== +! +! INTERFACE BLOCKS +! +!============================================================================== + interface operator(+) + module procedure ESMF_BaseTimeSum + end interface + interface operator(-) + module procedure ESMF_BaseTimeDifference + end interface + interface operator(/) + module procedure ESMF_BaseTimeQuotI,ESMF_BaseTimeQuotI8 + end interface + interface operator(.EQ.) + module procedure ESMF_BaseTimeEQ + end interface + interface operator(.NE.) + module procedure ESMF_BaseTimeNE + end interface + interface operator(.LT.) + module procedure ESMF_BaseTimeLT + end interface + interface operator(.GT.) + module procedure ESMF_BaseTimeGT + end interface + interface operator(.LE.) + module procedure ESMF_BaseTimeLE + end interface + interface operator(.GE.) + module procedure ESMF_BaseTimeGE + end interface + + +!============================================================================== + + contains + +!============================================================================== + +SUBROUTINE normalize_basetime( basetime ) + ! Factor so abs(Sn) < Sd and ensure that signs of S and Sn match. + ! Also, enforce consistency. + ! YR and MM fields are ignored. + IMPLICIT NONE + TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime + + !PRINT *,'DEBUG: BEGIN normalize_basetime()' + ! Consistency check... + IF ( basetime%Sd < 0 ) THEN + CALL wrf_error_fatal( & + 'normalize_basetime: denominator of seconds cannot be negative' ) + ENDIF + IF ( ( basetime%Sd == 0 ) .AND. ( basetime%Sn .NE. 0 ) ) THEN + CALL wrf_error_fatal( & + 'normalize_basetime: denominator of seconds cannot be zero when numerator is non-zero' ) + ENDIF + ! factor so abs(Sn) < Sd + IF ( basetime%Sd > 0 ) THEN + IF ( ABS( basetime%Sn ) .GE. basetime%Sd ) THEN + !PRINT *,'DEBUG: normalize_basetime() A1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S + ( basetime%Sn / basetime%Sd ) + basetime%Sn = mod( basetime%Sn, basetime%Sd ) + !PRINT *,'DEBUG: normalize_basetime() A2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + ! change sign of Sn if it does not match S + IF ( ( basetime%S > 0 ) .AND. ( basetime%Sn < 0 ) ) THEN + !PRINT *,'DEBUG: normalize_basetime() B1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S - 1_ESMF_KIND_I8 + basetime%Sn = basetime%Sn + basetime%Sd + !PRINT *,'DEBUG: normalize_basetime() B2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + IF ( ( basetime%S < 0 ) .AND. ( basetime%Sn > 0 ) ) THEN + !PRINT *,'DEBUG: normalize_basetime() C1: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + basetime%S = basetime%S + 1_ESMF_KIND_I8 + basetime%Sn = basetime%Sn - basetime%Sd + !PRINT *,'DEBUG: normalize_basetime() C2: S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd + ENDIF + ENDIF + !PRINT *,'DEBUG: END normalize_basetime()' +END SUBROUTINE normalize_basetime + +!============================================================================== + +! Add two basetimes + FUNCTION ESMF_BaseTimeSum( basetime1, basetime2 ) + TYPE(ESMF_BaseTime) :: ESMF_BaseTimeSum + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + ! locals + INTEGER (ESMF_KIND_I8) :: Sn1, Sd1, Sn2, Sd2, lcd +! PRINT *,'DEBUG: BEGIN ESMF_BaseTimeSum()' +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%S = ',basetime1%S +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sn = ',basetime1%Sn +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime1%Sd = ',basetime1%Sd +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%S = ',basetime2%S +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sn = ',basetime2%Sn +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): basetime2%Sd = ',basetime2%Sd + ESMF_BaseTimeSum = basetime1 + ESMF_BaseTimeSum%S = ESMF_BaseTimeSum%S + basetime2%S + Sn1 = basetime1%Sn + Sd1 = basetime1%Sd + Sn2 = basetime2%Sn + Sd2 = basetime2%Sd +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn1 = ',Sn1 +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd1 = ',Sd1 +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sn2 = ',Sn2 +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): Sd2 = ',Sd2 + IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): no fractions' + ESMF_BaseTimeSum%Sn = 0 + ESMF_BaseTimeSum%Sd = 0 + ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .EQ. 0 ) ) THEN + ESMF_BaseTimeSum%Sn = Sn1 + ESMF_BaseTimeSum%Sd = Sd1 + ELSE IF ( ( Sd1 .EQ. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN + ESMF_BaseTimeSum%Sn = Sn2 + ESMF_BaseTimeSum%Sd = Sd2 + ELSE IF ( ( Sd1 .NE. 0 ) .AND. ( Sd2 .NE. 0 ) ) THEN + CALL compute_lcd( Sd1 , Sd2 , lcd ) + ESMF_BaseTimeSum%Sd = lcd + ESMF_BaseTimeSum%Sn = (Sn1 * lcd / Sd1) + (Sn2 * lcd / Sd2) + ENDIF +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%S = ',ESMF_BaseTimeSum%S +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sn = ',ESMF_BaseTimeSum%Sn +! PRINT *,'DEBUG: ESMF_BaseTimeSum(): ESMF_BaseTimeSum%Sd = ',ESMF_BaseTimeSum%Sd + CALL normalize_basetime( ESMF_BaseTimeSum ) +! PRINT *,'DEBUG: END ESMF_BaseTimeSum()' + END FUNCTION ESMF_BaseTimeSum + + +! Subtract two basetimes + FUNCTION ESMF_BaseTimeDifference( basetime1, basetime2 ) + TYPE(ESMF_BaseTime) :: ESMF_BaseTimeDifference + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + ! locals + TYPE(ESMF_BaseTime) :: neg2 + + neg2%S = -basetime2%S + neg2%Sn = -basetime2%Sn + neg2%Sd = basetime2%Sd + + ESMF_BaseTimeDifference = basetime1 + neg2 + + END FUNCTION ESMF_BaseTimeDifference + + +! Divide basetime by 8-byte integer + FUNCTION ESMF_BaseTimeQuotI8( basetime, divisor ) + TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI8 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime + INTEGER(ESMF_KIND_I8), INTENT(IN) :: divisor + ! locals + INTEGER(ESMF_KIND_I8) :: d, n, dinit + +!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: S,Sn,Sd = ', & +! basetime%S,basetime%Sn,basetime%Sd +!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() A: divisor = ', divisor + IF ( divisor == 0_ESMF_KIND_I8 ) THEN + CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI8: divide by zero' ) + ENDIF + +!$$$ move to default constructor + ESMF_BaseTimeQuotI8%S = 0 + ESMF_BaseTimeQuotI8%Sn = 0 + ESMF_BaseTimeQuotI8%Sd = 0 + + ! convert to a fraction and divide by multipling the denonminator by + ! the divisor + IF ( basetime%Sd == 0 ) THEN + dinit = 1_ESMF_KIND_I8 + ELSE + dinit = basetime%Sd + ENDIF + n = basetime%S * dinit + basetime%Sn + d = dinit * divisor +!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() B: n,d = ',n,d + CALL simplify( n, d, ESMF_BaseTimeQuotI8%Sn, ESMF_BaseTimeQuotI8%Sd ) +!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() C: S,Sn,Sd = ', & +! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd + CALL normalize_basetime( ESMF_BaseTimeQuotI8 ) +!PRINT *,'DEBUG ESMF_BaseTimeQuotI8() D: S,Sn,Sd = ', & +! ESMF_BaseTimeQuotI8%S,ESMF_BaseTimeQuotI8%Sn,ESMF_BaseTimeQuotI8%Sd + END FUNCTION ESMF_BaseTimeQuotI8 + +! Divide basetime by integer + FUNCTION ESMF_BaseTimeQuotI( basetime, divisor ) + TYPE(ESMF_BaseTime) :: ESMF_BaseTimeQuotI + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime + INTEGER, INTENT(IN) :: divisor + IF ( divisor == 0 ) THEN + CALL wrf_error_fatal( 'ESMF_BaseTimeQuotI: divide by zero' ) + ENDIF + ESMF_BaseTimeQuotI = basetime / INT( divisor, ESMF_KIND_I8 ) + END FUNCTION ESMF_BaseTimeQuotI + + +! .EQ. for two basetimes + FUNCTION ESMF_BaseTimeEQ( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeEQ + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeEQ = ( retval .EQ. 0 ) + END FUNCTION ESMF_BaseTimeEQ + + +! .NE. for two basetimes + FUNCTION ESMF_BaseTimeNE( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeNE + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeNE = ( retval .NE. 0 ) + END FUNCTION ESMF_BaseTimeNE + + +! .LT. for two basetimes + FUNCTION ESMF_BaseTimeLT( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeLT + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeLT = ( retval .LT. 0 ) + END FUNCTION ESMF_BaseTimeLT + + +! .GT. for two basetimes + FUNCTION ESMF_BaseTimeGT( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeGT + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeGT = ( retval .GT. 0 ) + END FUNCTION ESMF_BaseTimeGT + + +! .LE. for two basetimes + FUNCTION ESMF_BaseTimeLE( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeLE + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeLE = ( retval .LE. 0 ) + END FUNCTION ESMF_BaseTimeLE + + +! .GE. for two basetimes + FUNCTION ESMF_BaseTimeGE( basetime1, basetime2 ) + LOGICAL :: ESMF_BaseTimeGE + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime1 + TYPE(ESMF_BaseTime), INTENT(IN) :: basetime2 + INTEGER :: retval + CALL seccmp( basetime1%S, basetime1%Sn, basetime1%Sd, & + basetime2%S, basetime2%Sn, basetime2%Sd, & + retval ) + ESMF_BaseTimeGE = ( retval .GE. 0 ) + END FUNCTION ESMF_BaseTimeGE + +!============================================================================== + +SUBROUTINE compute_lcd( e1, e2, lcd ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: e1, e2 + INTEGER(ESMF_KIND_I8), INTENT(OUT) :: lcd + INTEGER, PARAMETER :: nprimes = 9 + INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) + INTEGER i + INTEGER(ESMF_KIND_I8) d1, d2, p + + d1 = e1 ; d2 = e2 + IF ( d1 .EQ. 0 .AND. d2 .EQ. 0 ) THEN ; lcd = 1 ; RETURN ; ENDIF + IF ( d1 .EQ. 0 ) d1 = d2 + IF ( d2 .EQ. 0 ) d2 = d1 + IF ( d1 .EQ. d2 ) THEN ; lcd = d1 ; RETURN ; ENDIF + lcd = d1 * d2 + DO i = 1, nprimes + p = primes(i) + DO WHILE (lcd/p .NE. 0 .AND. & + mod(lcd/p,d1) .EQ. 0 .AND. mod(lcd/p,d2) .EQ. 0) + lcd = lcd / p + END DO + ENDDO +END SUBROUTINE compute_lcd + +!============================================================================== + +SUBROUTINE simplify( ni, di, no, do ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: ni, di + INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do + INTEGER, PARAMETER :: nprimes = 9 + INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,19,23/) + INTEGER(ESMF_KIND_I8) :: pr, d, n + INTEGER :: np + LOGICAL keepgoing + IF ( ni .EQ. 0 ) THEN + do = 1 + no = 0 + RETURN + ENDIF + IF ( mod( di , ni ) .EQ. 0 ) THEN + do = di / ni + no = 1 + RETURN + ENDIF + d = di + n = ni + DO np = 1, nprimes + pr = primes(np) + keepgoing = .TRUE. + DO WHILE ( keepgoing ) + keepgoing = .FALSE. + IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN + d = d / pr + n = n / pr + keepgoing = .TRUE. + ENDIF + ENDDO + ENDDO + do = d + no = n + RETURN +END SUBROUTINE simplify + +!============================================================================== + +! spaceship operator for seconds + Sn/Sd +SUBROUTINE seccmp(S1, Sn1, Sd1, S2, Sn2, Sd2, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + INTEGER(ESMF_KIND_I8), INTENT(IN) :: S1, Sn1, Sd1 + INTEGER(ESMF_KIND_I8), INTENT(IN) :: S2, Sn2, Sd2 +! local + INTEGER(ESMF_KIND_I8) :: lcd, n1, n2 + + n1 = Sn1 + n2 = Sn2 + if ( ( n1 .ne. 0 ) .or. ( n2 .ne. 0 ) ) then + CALL compute_lcd( Sd1, Sd2, lcd ) + if ( Sd1 .ne. 0 ) n1 = n1 * ( lcd / Sd1 ) + if ( Sd2 .ne. 0 ) n2 = n2 * ( lcd / Sd2 ) + endif + + if ( S1 .GT. S2 ) retval = 1 + if ( S1 .LT. S2 ) retval = -1 + IF ( S1 .EQ. S2 ) THEN + IF (n1 .GT. n2) retval = 1 + IF (n1 .LT. n2) retval = -1 + IF (n1 .EQ. n2) retval = 0 + ENDIF +END SUBROUTINE seccmp + +!============================================================================== + + end module ESMF_BaseTimeMod diff --git a/share/esmf_wrf_timemgr/ESMF_CalendarMod.F90 b/share/esmf_wrf_timemgr/ESMF_CalendarMod.F90 new file mode 100644 index 000000000000..dc874bdb9c02 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_CalendarMod.F90 @@ -0,0 +1,502 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Calendar Module + module ESMF_CalendarMod +! +!============================================================================== +! +! This file contains the Calendar class definition and all Calendar class +! methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!============================================================================== +!BOPI +! !MODULE: ESMF_CalendarMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ class { \tt ESMC\_Calendar} implementation +! +! See {\tt ../include/ESMC\_Calendar.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ + + INTEGER, PARAMETER :: mday(MONTHS_PER_YEAR) & + = (/31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER, PARAMETER :: mdayleap(MONTHS_PER_YEAR) & + = (/31,29,31,30,31,30,31,31,30,31,30,31/) + INTEGER, DIMENSION(365) :: daym + INTEGER, DIMENSION(366) :: daymleap + INTEGER :: mdaycum(0:MONTHS_PER_YEAR) + INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthedys(0:MONTHS_PER_YEAR) + TYPE(ESMF_BaseTime), TARGET :: monthedysleap(0:MONTHS_PER_YEAR) + + +!------------------------------------------------------------------------------ +! ! ESMF_CalKind_Flag +! +! ! F90 "enum" type to match C++ ESMC_CalKind_Flag enum + + type ESMF_CalKind_Flag + integer :: caltype + end type + + type(ESMF_CalKind_Flag), parameter :: & + ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & + ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(2) + +! type(ESMF_CalKind_Flag), parameter :: & +! ESMF_CALKIND_GREGORIAN = ESMF_CalKind_Flag(1), & +! ESMF_CALKIND_JULIAN = ESMF_CalKind_Flag(2), & +! ! like Gregorian, except Feb always has 28 days +! ESMF_CALKIND_NOLEAP = ESMF_CalKind_Flag(3), & +! ! 12 months, 30 days each +! ESMF_CALKIND_360DAY = ESMF_CalKind_Flag(4), & +! ! user defined +! ESMF_CALKIND_GENERIC = ESMF_CalKind_Flag(5), & +! ! track base time seconds only +! ESMF_CALKIND_NOCALENDAR = ESMF_CalKind_Flag(6) + +!------------------------------------------------------------------------------ +! ! ESMF_Calendar +! +! ! F90 class type to match C++ Calendar class in size only; +! ! all dereferencing within class is performed by C++ implementation +! +!------------------------------------------------------------------------------ +! +! ! ESMF_DaysPerYear +! + type ESMF_DaysPerYear + integer :: D = 0 ! whole days per year + integer :: Dn = 0 ! fractional days per year numerator + integer :: Dd = 1 ! fractional days per year denominator + end type ! e.g. for Venus, D=0, Dn=926, Dd=1000 +! +!------------------------------------------------------------------------------ +! ! ESMF_Calendar +! +! + type ESMF_Calendar + type(ESMF_CalKind_Flag) :: Type + logical :: Set = .false. + integer, dimension(MONTHS_PER_YEAR) :: DaysPerMonth = 0 + integer :: SecondsPerDay = 0 + integer :: SecondsPerYear = 0 + type(ESMF_DaysPerYear) :: DaysPerYear + end type +!------------------------------------------------------------------------------ +! !PUBLIC DATA: added by Juanxiong He, in order to breakthe cycle call between +! ESMF_Stubs and ESMF_Time + TYPE(ESMF_Calendar), public, save, pointer :: defaultCal ! Default Calendar + TYPE(ESMF_Calendar), public, save, pointer :: gregorianCal ! gregorian Calendar + TYPE(ESMF_Calendar), public, save, pointer :: noleapCal ! noleap Calendar + +! +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public initdaym +! public mday +! public mdayleap +! public monthbdys +! public monthbdysleap +! public monthedys +! public monthedysleap +! public daym +! public daymleap +! public mdaycum +! public mdayleapcum + public ndaysinmonth + public nsecondsinmonth + public ndaysinyear + public nsecondsinyear + public nmonthinyearsec + public ndayinyearsec + public nsecondsinyearmonth + public isleap + public ESMF_CalKind_Flag + public ESMF_CALKIND_GREGORIAN, ESMF_CALKIND_NOLEAP +! ESMF_CALKIND_360DAY, ESMF_CALKIND_NOCALENDAR +! public ESMF_CAL_JULIAN +! public ESMF_CAL_GENERIC + public ESMF_Calendar + public ESMF_DaysPerYear + +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_CalendarCreate + +! Required inherited and overridden ESMF_Base class methods + + public ESMF_CalendarInitialized ! Only in this implementation, intended + ! to be private within ESMF methods +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== + + contains + + +!============================================================================== +!BOP +! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type + +! !INTERFACE: + ! Private name; call using ESMF_CalendarCreate() + function ESMF_CalendarCreate(name, calkindflag, rc) + +! !RETURN VALUE: + type(ESMF_Calendar) :: ESMF_CalendarCreate + +! !ARGUMENTS: + character (len=*), intent(in), optional :: name + type(ESMF_CalKind_Flag), intent(in) :: calkindflag + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Creates and sets a {\tt calendar} to the given built-in +! {\tt ESMF\_CalKind_Flag}. +! +! This is a private method; invoke via the public overloaded entry point +! {\tt ESMF\_CalendarCreate()}. +! +! The arguments are: +! \begin{description} +! \item[{[name]}] +! The name for the newly created calendar. If not specified, a +! default unique name will be generated: "CalendarNNN" where NNN +! is a unique sequence number from 001 to 999. +! \item[calkindflag] +! The built-in {\tt ESMF\_CalKind_Flag}. Valid values are: +! {\tt ESMF\_CAL\_360DAY}, {\tt ESMF\_CAL\_GREGORIAN}, +! {\tt ESMF\_CAL\_JULIANDAY}, {\tt ESMF\_CAL\_NOCALENDAR}, and +! {\tt ESMF\_CAL\_NOLEAP}. +! See the "Time Manager Reference" document for a description of +! each calendar type. +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +!EOP +! !REQUIREMENTS: +! TMGn.n.n + type(ESMF_DaysPerYear) :: dayspy + + if ( present(rc) ) rc = ESMF_FAILURE +! Calendar is hard-coded. Use ESMF library if more flexibility is needed. +! write(6,*) 'tcx ESMF_CalendarCreate ',calkindflag%caltype, ESMF_CALKIND_NOLEAP%caltype, ESMF_CALKIND_GREGORIAN%caltype + if ( calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype ) then +! write(6,*) 'tcx ESMF_CalendarCreate: initialize noleap calendar ' + ESMF_CalendarCreate%Type = ESMF_CALKIND_NOLEAP + elseif ( calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype ) then +! write(6,*) 'tcx ESMF_CalendarCreate: initialize gregorian calendar ' + ESMF_CalendarCreate%Type = ESMF_CALKIND_GREGORIAN + else +! write(6,*) 'tcx ESMF_CalendarCreate: ERROR initialize invalid calendar' + call wrf_error_fatal( "Error:: ESMF_CalendarCreate invalid calendar") + endif + +!$$$ This is a bug on some systems -- need initial value set by compiler at +!$$$ startup. + ESMF_CalendarCreate%Set = .true. + ESMF_CalendarCreate%SecondsPerDay = SECONDS_PER_DAY +! DaysPerYear and SecondsPerYear are incorrect for Gregorian calendars... + dayspy%D = size(daym) + dayspy%Dn = 0 + dayspy%Dd = 1 + ESMF_CalendarCreate%DaysPerYear = dayspy + ESMF_CalendarCreate%SecondsPerYear = ESMF_CalendarCreate%SecondsPerDay & + * dayspy%D + ESMF_CalendarCreate%DaysPerMonth(:) = mday(:) + + if ( present(rc) ) rc = ESMF_SUCCESS + + end function ESMF_CalendarCreate + + +!============================================================================== +!BOP +! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created + +! !INTERFACE: + function ESMF_CalendarInitialized(calendar) + +! !RETURN VALUE: + logical ESMF_CalendarInitialized + +! !ARGUMENTS: + type(ESMF_Calendar), intent(in) :: calendar + +! !DESCRIPTION: +!EOP +! !REQUIREMENTS: +! TMGn.n.n + ESMF_CalendarInitialized = calendar%set + if ( calendar%SecondsPerDay == 0 ) & + ESMF_CalendarInitialized = .false. + + end function ESMF_CalendarInitialized + +!============================================================================== + +SUBROUTINE initdaym + IMPLICIT NONE + INTEGER i,j,m + + m = 1 + mdaycum(0) = 0 +!$$$ push this down into ESMF_BaseTime constructor + monthbdys(0)%S = 0 + monthbdys(0)%Sn = 0 + monthbdys(0)%Sd = 0 + DO i = 1,MONTHS_PER_YEAR + DO j = 1,mday(i) + daym(m) = i + m = m + 1 + ENDDO + mdaycum(i) = mdaycum(i-1) + mday(i) +!$$$ push this down into ESMF_BaseTime constructor + monthbdys(i)%S = SECONDS_PER_DAY * INT( mdaycum(i), ESMF_KIND_I8 ) + monthbdys(i)%Sn = 0 + monthbdys(i)%Sd = 0 + ENDDO + ! End of month seconds, day before the beginning of next month + DO i = 0,MONTHS_PER_YEAR + j = i + 1 + if ( i == MONTHS_PER_YEAR ) j = 0 + monthedys(i) = monthbdys(j) + monthedys(i)%S = monthedys(i)%S - SECONDS_PER_DAY + ENDDO + + m = 1 + mdayleapcum(0) = 0 +!$$$ push this down into ESMF_BaseTime constructor + monthbdysleap(0)%S = 0 + monthbdysleap(0)%Sn = 0 + monthbdysleap(0)%Sd = 0 + DO i = 1,MONTHS_PER_YEAR + DO j = 1,mdayleap(i) + daymleap(m) = i + m = m + 1 + ENDDO + mdayleapcum(i) = mdayleapcum(i-1) + mdayleap(i) +!$$$ push this down into ESMF_BaseTime constructor + monthbdysleap(i)%S = SECONDS_PER_DAY * INT( mdayleapcum(i), ESMF_KIND_I8 ) + monthbdysleap(i)%Sn = 0 + monthbdysleap(i)%Sd = 0 + ENDDO + ! End of month seconds, day before the beginning of next month + DO i = 0,MONTHS_PER_YEAR + j = i + 1 + if ( i == MONTHS_PER_YEAR ) j = 0 + monthedysleap(i) = monthbdysleap(j) + monthedysleap(i)%S = monthedysleap(i)%S - SECONDS_PER_DAY + ENDDO + +END SUBROUTINE initdaym + +!============================================================================== + +integer(esmf_kind_i8) FUNCTION nsecondsinyear ( year, calkindflag ) + ! Compute the number of seconds in the given year + IMPLICIT NONE + INTEGER, INTENT(IN) :: year + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + nsecondsinyear = SECONDS_PER_DAY * INT( ndaysinyear(year, calkindflag) , ESMF_KIND_I8 ) + +END FUNCTION nsecondsinyear + +!============================================================================== + +integer function ndaysinmonth( year,month,calkindflag) + ! Compute number of days in month for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year,month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + + IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN + CALL wrf_error_fatal( 'ERROR ndaysinmonth: MONTH out of range' ) + ENDIF + + IF ( isleap(year,calkindflag) ) THEN + ndaysinmonth = mdayleap(month) + ELSE + ndaysinmonth = mday(month) + ENDIF + +END function ndaysinmonth +!============================================================================== + +integer(esmf_kind_i8) function nsecondsinmonth( year,month,calkindflag) + ! Compute number of days in month for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year,month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + + nsecondsinmonth = ndaysinmonth(year,month,calkindflag)*SECONDS_PER_DAY + +END function nsecondsinmonth + +!============================================================================== + +integer function nmonthinyearsec(year,basetime,calkindflag) + ! Compute month for year, basetime, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + type(ESMF_BaseTime), intent(in) :: basetime + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + integer :: mm,i + + IF ( isleap(year,calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + MM = -1 + DO i = 1,MONTHS_PER_YEAR + IF ( ( basetime >= MMbdys(i-1) ) .AND. ( basetime < MMbdys(i) ) ) THEN + MM = i + EXIT + ENDIF + ENDDO + IF ( MM == -1 ) THEN + CALL wrf_error_fatal( 'nmonthinyearsec: could not extract month of year from time' ) + ENDIF + nmonthinyearsec = mm + +END function nmonthinyearsec + +!============================================================================== +integer function ndayinyearsec(year, basetime, calkindflag) + ! Compute day of year for year, basetime, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + type(ESMF_BaseTime), intent(in) :: basetime + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + TYPE(ESMF_BaseTime) :: tmpbasetime + integer :: mm + + mm = nmonthinyearsec(year, basetime, calkindflag) + + IF ( isleap(year,calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + tmpbasetime = basetime - MMbdys(mm-1) + ndayinyearsec = ( tmpbasetime%S / SECONDS_PER_DAY ) + 1 + +end function ndayinyearsec +!============================================================================== +integer(esmf_kind_i8) function nsecondsinyearmonth(year, month, calkindflag) + ! Compute number of seconds from start of year for year, month, cal + IMPLICIT NONE + INTEGER, INTENT(in) :: year + INTEGER, INTENT(in) :: month + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + ! locals + TYPE(ESMF_BaseTime), pointer :: MMbdys(:) + + IF ( ( MONTH < 1 ) .OR. ( MONTH > MONTHS_PER_YEAR ) ) THEN + CALL wrf_error_fatal( 'ERROR nsecondsinyearmonth(): MONTH out of range' ) + ENDIF + + IF ( isleap(year, calkindflag) ) THEN + MMbdys => monthbdysleap + ELSE + MMbdys => monthbdys + ENDIF + + nsecondsinyearmonth = MMbdys(month-1)%s + +end function nsecondsinyearmonth +!============================================================================== + +integer FUNCTION ndaysinyear ( year,calkindflag ) + ! Compute the number of days in the given year + IMPLICIT NONE + INTEGER, INTENT(IN) :: year + type(ESMF_CalKind_Flag),intent(in) :: calkindflag + + IF ( isleap( year,calkindflag ) ) THEN + ndaysinyear = 366 + ELSE + ndaysinyear = 365 + ENDIF +END FUNCTION ndaysinyear + +!============================================================================== + +logical FUNCTION isleap ( year, calkindflag ) + ! Compute the number of days in February for the given year + IMPLICIT NONE + INTEGER,intent(in) :: year + type(ESMF_CalKind_Flag) :: calkindflag + ! local + INTEGER :: lyear + + lyear = abs(year) ! make sure it handles negative years + + isleap = .false. ! By default, February has 28 days ... + + if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then + IF (MOD(lyear,4).eq.0) THEN + isleap = .true. ! But every four years, it has 29 days ... + IF (MOD(lyear,100).eq.0) THEN + isleap = .false. ! Except every 100 years, when it has 28 days ... + IF (MOD(lyear,400).eq.0) THEN + isleap = .true. ! Except every 400 years, when it has 29 days. + END IF + END IF + END IF + endif + +END FUNCTION isleap + +!============================================================================== +end module ESMF_CalendarMod diff --git a/share/esmf_wrf_timemgr/ESMF_ClockMod.F90 b/share/esmf_wrf_timemgr/ESMF_ClockMod.F90 new file mode 100644 index 000000000000..d634362e8da2 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_ClockMod.F90 @@ -0,0 +1,1249 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Clock Module + module ESMF_ClockMod +! +!============================================================================== +! +! This file contains the Clock class definition and all Clock class methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!============================================================================== +!BOPI +! !MODULE: ESMF_ClockMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ class {\tt ESMC\_Time} implementation +! +! See {\tt ../include/ESMC\_Clock.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! associated derived types + use ESMF_TimeIntervalMod ! , only : ESMF_TimeInterval + use ESMF_TimeMod ! , only : ESMF_Time + use ESMF_AlarmMod, only : ESMF_Alarm + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Clock +! +! ! F90 class type to match C++ Clock class in size only; +! ! all dereferencing within class is performed by C++ implementation + + +! internals for ESMF_Clock + type ESMF_ClockInt + type(ESMF_TimeInterval) :: TimeStep + type(ESMF_Time) :: StartTime + type(ESMF_Time) :: StopTime + type(ESMF_Time) :: RefTime + type(ESMF_Time) :: CurrTime + type(ESMF_Time) :: PrevTime + integer(ESMF_KIND_I8) :: AdvanceCount + integer :: ClockMutex + integer :: NumAlarms + ! Note: to mimic ESMF 2.1.0+, AlarmList is maintained + ! within ESMF_Clock even though copies of each alarm are + ! returned from ESMF_AlarmCreate() at the same time they + ! are copied into the AlarmList! This duplication is not + ! as hideous as it might be because the ESMF_Alarm type + ! has data members that are all POINTERs (thus the horrible + ! shallow-copy-masquerading-as-reference-copy hack works). + type(ESMF_Alarm), pointer, dimension(:) :: AlarmList => null() + end type + +! Actual public type: this bit allows easy mimic of "deep" ESMF_ClockCreate +! in ESMF 2.1.0+ +! NOTE: DO NOT ADD NON-POINTER STATE TO THIS DATA TYPE. It emulates ESMF +! shallow-copy-masquerading-as-reference-copy. + type ESMF_Clock + type(ESMF_ClockInt), pointer :: clockint => null() + end type + +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_Clock + public ESMF_ClockInt ! needed on AIX but not PGI +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_ClockCreate + public ESMF_ClockDestroy + public ESMF_ClockSet +! public ESMF_ClockSetOLD + public ESMF_ClockGet +! public ESMF_ClockGetAdvanceCount +! public ESMF_ClockGetTimeStep +! public ESMF_ClockSetTimeStep +! public ESMF_ClockGetCurrTime +! public ESMF_ClockSetCurrTime +! public ESMF_ClockGetStartTime +! public ESMF_ClockGetStopTime +! public ESMF_ClockGetRefTime +! public ESMF_ClockGetPrevTime +! public ESMF_ClockGetCurrSimTime +! public ESMF_ClockGetPrevSimTime +! This must be public for ESMF_AlarmClockMod... + public ESMF_ClockAddAlarm + public ESMF_ClockGetAlarmList +! public ESMF_ClockGetNumAlarms +! public ESMF_ClockSyncToWallClock + public ESMF_ClockAdvance + public ESMF_ClockIsStopTime + public ESMF_ClockStopTimeDisable + +! Required inherited and overridden ESMF_Base class methods + +! public ESMF_ClockRead +! public ESMF_ClockWrite + public ESMF_ClockValidate + public ESMF_ClockPrint +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== + + contains + +!============================================================================== +! +! This section includes the Set methods. +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockSetOLD - Initialize a clockint + +! !INTERFACE: + subroutine ESMF_ClockSetOLD(clockint, TimeStep, StartTime, & + StopTime, RefTime, rc) + +! !ARGUMENTS: + type(ESMF_ClockInt), intent(out) :: clockint + type(ESMF_TimeInterval), intent(in), optional :: TimeStep + type(ESMF_Time), intent(in) :: StartTime + type(ESMF_Time), intent(in) :: StopTime + type(ESMF_Time), intent(in), optional :: RefTime + integer, intent(out), optional :: rc +! Local + integer i + +! !DESCRIPTION: +! Initialize an {\tt ESMF\_Clock} +! +! The arguments are: +! \begin{description} +! \item[clockint] +! The object instance to initialize +! \item[{[TimeStep]}] +! The {\tt ESMF\_Clock}'s time step interval +! \item[StartTime] +! The {\tt ESMF\_Clock}'s starting time +! \item[StopTime] +! The {\tt ESMF\_Clock}'s stopping time +! \item[{[RefTime]}] +! The {\tt ESMF\_Clock}'s reference time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.1, TMG3.4.4 +!EOP + IF ( PRESENT(TimeStep) ) clockint%TimeStep = TimeStep + IF ( PRESENT(RefTime) )THEN + clockint%RefTime = RefTime + ELSE + clockint%RefTime = StartTime + END IF + clockint%CurrTime = StartTime + clockint%StartTime = StartTime + clockint%StopTime = StopTime + clockint%NumAlarms = 0 + clockint%AdvanceCount = 0 + ALLOCATE(clockint%AlarmList(MAX_ALARMS)) + ! TBH: This incredible hack can be removed once ESMF_*Validate() + ! TBH: can tell if a deep ESMF_* was created or not. + DO i = 1, MAX_ALARMS + NULLIFY( clockint%AlarmList( i )%alarmint ) + ENDDO + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockSetOLD + + +! !IROUTINE: ESMF_ClockSet - Set clock properties -- for compatibility with ESMF 2.0.1 + +! !INTERFACE: + subroutine ESMF_ClockSet(clock, TimeStep, StartTime, StopTime, & + RefTime, CurrTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_TimeInterval), intent(in), optional :: TimeStep + type(ESMF_Time), intent(in), optional :: StartTime + type(ESMF_Time), intent(in), optional :: StopTime + type(ESMF_Time), intent(in), optional :: RefTime + type(ESMF_Time), intent(in), optional :: CurrTime + integer, intent(out), optional :: rc +! Local + integer ierr + +! !DESCRIPTION: +! Initialize an {\tt ESMF\_Clock} +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to initialize +! \item[{[TimeStep]}] +! The {\tt ESMF\_Clock}'s time step interval +! \item[StartTime] +! The {\tt ESMF\_Clock}'s starting time +! \item[StopTime] +! The {\tt ESMF\_Clock}'s stopping time +! \item[{[RefTime]}] +! The {\tt ESMF\_Clock}'s reference time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.1, TMG3.4.4 +!EOP + ierr = ESMF_SUCCESS + IF ( PRESENT(TimeStep) ) THEN + CALL ESMF_ClockSetTimeStep ( clock, TimeStep, rc=ierr ) + ENDIF + IF ( PRESENT(RefTime) ) clock%clockint%RefTime = RefTime + IF ( PRESENT(StartTime) ) clock%clockint%StartTime = StartTime + IF ( PRESENT(StopTime) ) clock%clockint%StopTime = StopTime + IF ( PRESENT(CurrTime) ) THEN + CALL ESMF_ClockSetCurrTime(clock, CurrTime, rc=ierr) + ENDIF + IF ( PRESENT(rc) ) rc = ierr + + end subroutine ESMF_ClockSet + + +! Create ESMF_Clock using ESMF 2.1.0+ semantics + FUNCTION ESMF_ClockCreate( name, TimeStep, StartTime, StopTime, & + RefTime, rc ) + ! return value + type(ESMF_Clock) :: ESMF_ClockCreate + ! !ARGUMENTS: + character (len=*), intent(in), optional :: name + type(ESMF_TimeInterval), intent(in), optional :: TimeStep + type(ESMF_Time), intent(in) :: StartTime + type(ESMF_Time), intent(in) :: StopTime + type(ESMF_Time), intent(in), optional :: RefTime + integer, intent(out), optional :: rc + ! locals + type(ESMF_Clock) :: clocktmp + ! TBH: ignore allocate errors, for now + ALLOCATE( clocktmp%clockint ) + CALL ESMF_ClockSetOLD( clocktmp%clockint, & + TimeStep= TimeStep, & + StartTime=StartTime, & + StopTime= StopTime, & + RefTime=RefTime, rc=rc ) + ESMF_ClockCreate = clocktmp + END FUNCTION ESMF_ClockCreate + + ! + ! Deallocate memory for ESMF_Clock + ! + SUBROUTINE ESMF_ClockDestroy( clock, rc ) + + TYPE(ESMF_Clock), INTENT(INOUT) :: clock + INTEGER, INTENT( OUT), OPTIONAL :: rc + + if (associated(clock%clockint)) then + if (associated(clock%clockint%AlarmList)) deallocate(clock%clockint%AlarmList) + deallocate(clock%clockint) + endif + + ! TBH: ignore deallocate errors, for now + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + + END SUBROUTINE ESMF_ClockDestroy + + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGet - Get clock properties -- for compatibility with ESMF 2.0.1 + +! tcraig added alarmCount for ccsm4, consistent with ESMF3 interface + +! !INTERFACE: + subroutine ESMF_ClockGet(clock, StartTime, CurrTime, & + AdvanceCount, StopTime, TimeStep, & + PrevTime, RefTime, AlarmCount, & + rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out), optional :: StartTime + type(ESMF_Time), intent(out), optional :: CurrTime + type(ESMF_Time), intent(out), optional :: StopTime + type(ESMF_Time), intent(out), optional :: PrevTime + type(ESMF_Time), intent(out), optional :: RefTime + integer(ESMF_KIND_I8), intent(out), optional :: AdvanceCount + integer, intent(out), optional :: AlarmCount + type(ESMF_TimeInterval), intent(out), optional :: TimeStep + integer, intent(out), optional :: rc + integer :: ierr + +! !DESCRIPTION: +! Returns the number of times the {\tt ESMF\_Clock} has been advanced +! (time stepped) +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the advance count from +! \item[StartTime] +! The start time +! \item[CurrTime] +! The current time +! \item[AdvanceCount] +! The number of times the {\tt ESMF\_Clock} has been advanced +! \item[StopTime] +! The {\tt ESMF\_Clock}'s stopping time +! \item[{[TimeStep]}] +! The {\tt ESMF\_Clock}'s time step interval +! \item[{[PrevTime]}] +! The {\tt ESMF\_Clock}'s previous current time +! \item[{[PrevTime]}] +! The {\tt ESMF\_Clock}'s reference time +! \item[{[AlarmCount]}] +! The {\tt ESMF\_Clock}'s number of valid alarms +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG3.5.1 +!EOP + ierr = ESMF_SUCCESS + + IF ( PRESENT (StartTime) ) THEN + CALL ESMF_ClockGetStartTime( clock, StartTime=StartTime, rc=ierr ) + ENDIF + IF ( PRESENT (CurrTime) ) THEN + CALL ESMF_ClockGetCurrTime( clock , CurrTime, ierr ) + ENDIF + IF ( PRESENT (StopTime) ) THEN + CALL ESMF_ClockGetStopTime( clock , StopTime, ierr ) + ENDIF + IF ( PRESENT (AdvanceCount) ) THEN + CALL ESMF_ClockGetAdvanceCount(clock, AdvanceCount, ierr) + ENDIF + IF ( PRESENT (TimeStep) ) THEN + CALL ESMF_ClockGetTimeStep(clock, TimeStep, ierr) + ENDIF + IF ( PRESENT (PrevTime) ) THEN + CALL ESMF_ClockGetPrevTime(clock, PrevTime, ierr) + ENDIF + IF ( PRESENT (RefTime) ) THEN + CALL ESMF_ClockGetRefTime(clock, RefTime, ierr) + ENDIF + IF ( PRESENT (AlarmCount) ) THEN + CALL ESMF_ClockGetNumAlarms(clock, AlarmCount, ierr) + ENDIF + + IF ( PRESENT (rc) ) THEN + rc = ierr + ENDIF + + end subroutine ESMF_ClockGet + + +! !IROUTINE: ESMF_ClockGetAdvanceCount - Get the clock's advance count + +! !INTERFACE: + subroutine ESMF_ClockGetAdvanceCount(clock, AdvanceCount, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + integer(ESMF_KIND_I8), intent(out) :: AdvanceCount + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Returns the number of times the {\tt ESMF\_Clock} has been advanced +! (time stepped) +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the advance count from +! \item[AdvanceCount] +! The number of times the {\tt ESMF\_Clock} has been advanced +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG3.5.1 +!EOP + + AdvanceCount = clock%clockint%AdvanceCount + + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetAdvanceCount + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetTimeStep - Get a clock's timestep interval + +! !INTERFACE: + subroutine ESMF_ClockGetTimeStep(clock, TimeStep, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_TimeInterval), intent(out) :: TimeStep + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s timestep interval +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the time step from +! \item[TimeStep] +! The time step +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.2 +!EOP + + TimeStep = clock%clockint%TimeStep + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetTimeStep + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockSetTimeStep - Set a clock's timestep interval + +! !INTERFACE: + subroutine ESMF_ClockSetTimeStep(clock, TimeStep, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_TimeInterval), intent(in) :: TimeStep + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Clock}'s timestep interval +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to set the time step +! \item[TimeStep] +! The time step +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.4.2 +!EOP + + clock%clockint%TimeStep = TimeStep + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockSetTimeStep + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetCurrTime - Get a clock's current time + +! !INTERFACE: + subroutine ESMF_ClockGetCurrTime(clock, CurrTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out) :: CurrTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s current time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the current time from +! \item[CurrTime] +! The current time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.4 +!EOP + + CurrTime = clock%clockint%CurrTime + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + end subroutine ESMF_ClockGetCurrTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockSetCurrTime - Set a clock's current time + +! !INTERFACE: + subroutine ESMF_ClockSetCurrTime(clock, CurrTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_Time), intent(in) :: CurrTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Clock}'s current time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to set the current time from +! \item[CurrTime] +! The current time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.4.3 +!EOP + + clock%clockint%CurrTime = CurrTime + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockSetCurrTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetStartTime - Get a clock's start time + +! !INTERFACE: + subroutine ESMF_ClockGetStartTime(clock, StartTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out) :: StartTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s start time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the start time from +! \item[StartTime] +! The start time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.3 +!EOP + + StartTime = clock%clockint%StartTime + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetStartTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetStopTime - Get a clock's stop time + +! !INTERFACE: + subroutine ESMF_ClockGetStopTime(clock, StopTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out) :: StopTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s stop time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the stop time from +! \item[StopTime] +! The stop time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.3 +!EOP + + StopTime = clock%clockint%StopTime + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetStopTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetRefTime - Get a clock's reference time + +! !INTERFACE: + subroutine ESMF_ClockGetRefTime(clock, RefTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out) :: RefTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s reference time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the reference time from +! \item[RefTime] +! The reference time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.3 +!EOP + refTime = clock%clockint%RefTime + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + end subroutine ESMF_ClockGetRefTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetPrevTime - Get a clock's previous current time + +! !INTERFACE: + subroutine ESMF_ClockGetPrevTime(clock, PrevTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Time), intent(out) :: PrevTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s previous current time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the previous current time from +! \item[PrevTime] +! The previous current time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.4 +!EOP + + prevTime = Clock%clockint%CurrTime - Clock%clockint%TimeStep + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + end subroutine ESMF_ClockGetPrevTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetCurrSimTime - Get a clock's current simulation time + +! !INTERFACE: + subroutine ESMF_ClockGetCurrSimTime(clock, CurrSimTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_TimeInterval), intent(out) :: CurrSimTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s current simulation time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the current simulation time from +! \item[CurrSimTime] +! The current simulation time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.5 +!EOP + CALL wrf_error_fatal( 'ESMF_ClockGetCurrSimTime not supported' ) + end subroutine ESMF_ClockGetCurrSimTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetPrevSimTime - Get a clock's previous simulation time + +! !INTERFACE: + subroutine ESMF_ClockGetPrevSimTime(clock, PrevSimTime, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_TimeInterval), intent(out) :: PrevSimTime + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s previous simulation time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the previous simulation time from +! \item[PrevSimTime] +! The previous simulation time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.5.5 +!EOP + CALL wrf_error_fatal( 'ESMF_ClockGetPrevSimTime not supported' ) + end subroutine ESMF_ClockGetPrevSimTime + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockAddAlarm - Add an alarm to a clock's alarm list + +! !INTERFACE: + subroutine ESMF_ClockAddAlarm(clock, Alarm, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_Alarm), intent(inout) :: Alarm + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Add an {\tt ESMF\_Alarm} to an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to add an {\tt ESMF\_Alarm} to +! \item[Alarm] +! The {\tt ESMF\_Alarm} to add to the {\tt ESMF\_Clock}'s +! {\tt ESMF\_Alarm} list +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.1, TMG4.2 +!EOP + + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + clock%clockint%NumAlarms = clock%clockint%NumAlarms + 1 + IF ( clock%clockint%NumAlarms > SIZE (clock%clockint%AlarmList) ) THEN + CALL wrf_error_fatal ( 'ESMF_ClockAddAlarm: too many alarms' ) + ELSE IF ( .NOT. ASSOCIATED( Alarm%alarmint ) ) THEN + CALL wrf_error_fatal ( & + 'ESMF_ClockAddAlarm: alarm not created' ) + ELSE +!TBH: why do all this initialization here? + IF ( Alarm%alarmint%RingTimeSet ) THEN + Alarm%alarmint%PrevRingTime = Alarm%alarmint%RingTime - & + Alarm%alarmint%RingInterval + ELSE + Alarm%alarmint%PrevRingTime = clock%clockint%CurrTime + ENDIF + Alarm%alarmint%Ringing = .FALSE. + + ! finally, load the alarm into the list + clock%clockint%AlarmList(clock%clockint%NumAlarms) = Alarm + ENDIF + + end subroutine ESMF_ClockAddAlarm + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetAlarmList - Get a clock's alarm list + +! !INTERFACE: + subroutine ESMF_ClockGetAlarmList(clock, AlarmList, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_Alarm), pointer :: AlarmList(:) + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get an {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the {\tt ESMF\_Alarm} list from +! \item[AlarmList] +! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.3 +!EOP + + AlarmList => clock%clockint%AlarmList + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetAlarmList + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockGetNumAlarms - Get the number of alarms in a clock's alarm list + +! !INTERFACE: + subroutine ESMF_ClockGetNumAlarms(clock, NumAlarms, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + integer, intent(out) :: NumAlarms + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Get the number of {\tt ESMF\_Alarm}s in an {\tt ESMF\_Clock}'s +! {\tt ESMF\_Alarm} list +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to get the number of {\tt ESMF\_Alarm}s from +! \item[NumAlarms] +! The number of {\tt ESMF\_Alarm}s in the {\tt ESMF\_Clock}'s +! {\tt ESMF\_Alarm} list +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG4.3 +!EOP + + NumAlarms = clock%clockint%NumAlarms + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockGetNumAlarms + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockSyncToWallClock - Set clock's current time to wall clock time + +! !INTERFACE: + subroutine ESMF_ClockSyncToWallClock(clock, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Set an {\tt ESMF\_Clock}'s current time to wall clock time +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to synchronize to wall clock time +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.4.5 +!EOP + CALL wrf_error_fatal( 'ESMF_ClockSyncToWallClock not supported' ) + end subroutine ESMF_ClockSyncToWallClock + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockAdvance - Advance a clock's current time by one time step + +! !INTERFACE: + subroutine ESMF_ClockAdvance(clock, RingingAlarmList, & + NumRingingAlarms, rc) + +use ESMF_TimeMod + +! !ARGUMENTS: + type(ESMF_Clock), intent(inout) :: clock + type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out), optional :: & + RingingAlarmList + integer, intent(out), optional :: NumRingingAlarms + integer, intent(out), optional :: rc +! Local + logical pred1, pred2, pred3 + integer i, n + type(ESMF_Alarm) :: alarm +! +! !DESCRIPTION: +! Advance an {\tt ESMF\_Clock}'s current time by one time step +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to advance +! \item[{[RingingAlarmList]}] +! Return a list of any ringing alarms after the time step +! \item[{[NumRingingAlarms]}] +! The number of ringing alarms returned +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG3.4.1 +!EOP + clock%clockint%CurrTime = clock%clockint%CurrTime + & + clock%clockint%TimeStep + + IF ( Present(NumRingingAlarms) ) NumRingingAlarms = 0 + clock%clockint%AdvanceCount = clock%clockint%AdvanceCount + 1 + DO i = 1, MAX_ALARMS + alarm = clock%clockint%AlarmList(i) + ! TBH: This is really dangerous. We need to be able to NULLIFY + ! TBH: alarmint at compile-time (F95 synax) to make this safe. +!$$$TBH: see if F95 compile-time pointer-nullification is supported by all +!$$$TBH: compilers we support + IF ( ASSOCIATED( alarm%alarmint ) ) THEN + IF ( alarm%alarmint%Enabled ) THEN + IF ( alarm%alarmint%RingIntervalSet ) THEN + pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE. + IF ( alarm%alarmint%StopTimeSet ) THEN + PRED1 = clock%clockint%CurrTime > alarm%alarmint%StopTime + ENDIF + IF ( alarm%alarmint%RingTimeSet ) THEN + PRED2 = ( alarm%alarmint%RingTime <= clock%clockint%CurrTime & + .AND. clock%clockint%CurrTime < alarm%alarmint%RingTime + & + clock%clockint%TimeStep ) + ENDIF + IF ( alarm%alarmint%RingIntervalSet ) THEN + PRED3 = ( alarm%alarmint%PrevRingTime + alarm%alarmint%RingInterval <= & + clock%clockint%CurrTime ) + ENDIF + IF ( ( .NOT. ( pred1 ) ) .AND. & + ( ( pred2 ) .OR. ( pred3 ) ) ) THEN + alarm%alarmint%Ringing = .TRUE. + IF ( PRED3) alarm%alarmint%PrevRingTime = alarm%alarmint%PrevRingTime + & + alarm%alarmint%RingInterval + IF ( PRESENT( RingingAlarmList ) .AND. & + PRESENT ( NumRingingAlarms ) ) THEN + NumRingingAlarms = NumRingingAlarms + 1 + RingingAlarmList( NumRingingAlarms ) = alarm + ENDIF + ENDIF + ELSE IF ( alarm%alarmint%RingTimeSet ) THEN + IF ( alarm%alarmint%RingTime <= clock%clockint%CurrTime ) THEN + alarm%alarmint%Ringing = .TRUE. + IF ( PRESENT( RingingAlarmList ) .AND. & + PRESENT ( NumRingingAlarms ) ) THEN + NumRingingAlarms = NumRingingAlarms + 1 + RingingAlarmList( NumRingingAlarms ) = alarm + ENDIF + ENDIF + ENDIF + IF ( alarm%alarmint%StopTimeSet ) THEN + ENDIF + ENDIF + ENDIF + clock%clockint%AlarmList(i) = alarm + ENDDO + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + + end subroutine ESMF_ClockAdvance + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockStopTimeDisable - NOOP for compatibility with ESMF 2.1.0+ + +! !INTERFACE: + subroutine ESMF_ClockStopTimeDisable(clock, rc) +! +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + integer, intent(out), optional :: rc + + rc = ESMF_SUCCESS + + end subroutine ESMF_ClockStopTimeDisable + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockIsStopTime - Has the clock reached its stop time ? + +! !INTERFACE: + function ESMF_ClockIsStopTime(clock, rc) +! +! !RETURN VALUE: + logical :: ESMF_ClockIsStopTime + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Return true if {\tt ESMF\_Clock} has reached its stop time, false +! otherwise +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to check +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} + +! !REQUIREMENTS: +! TMG3.5.6 +!EOP + + if ( clock%clockint%CurrTime .GE. clock%clockint%StopTime ) THEN + ESMF_ClockIsStopTime = .TRUE. + else + ESMF_ClockIsStopTime = .FALSE. + endif + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + + end function ESMF_ClockIsStopTime + +!------------------------------------------------------------------------------ +! +! This section defines the overridden Read, Write, Validate and Print methods +! from the ESMF_Base class +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockRead - Restores a clock + +! !INTERFACE: + subroutine ESMF_ClockRead(clock, TimeStep, StartTime, StopTime, & + RefTime, CurrTime, PrevTime, AdvanceCount, & + AlarmList, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(out) :: clock + type(ESMF_TimeInterval), intent(in) :: TimeStep + type(ESMF_Time), intent(in) :: StartTime + type(ESMF_Time), intent(in) :: StopTime + type(ESMF_Time), intent(in) :: RefTime + type(ESMF_Time), intent(in) :: CurrTime + type(ESMF_Time), intent(in) :: PrevTime + integer(ESMF_KIND_I8), intent(in) :: AdvanceCount + type(ESMF_Alarm), dimension(MAX_ALARMS), intent(in) :: AlarmList + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Restore an {\tt ESMF\_Clock} +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to restore +! \item[TimeStep] +! The {\tt ESMF\_Clock}'s time step interval +! \item[StartTime] +! The {\tt ESMF\_Clock}'s starting time +! \item[StopTime] +! The {\tt ESMF\_Clock}'s stopping time +! \item[RefTime] +! The {\tt ESMF\_Clock}'s reference time +! \item[CurrTime] +! The {\tt ESMF\_Clock}'s current time +! \item[PrevTime] +! The {\tt ESMF\_Clock}'s previous time +! \item[AdvanceCount] +! The number of times the {\tt ESMF\_Clock} has been advanced +! \item[AlarmList] +! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +!EOP + CALL wrf_error_fatal( 'ESMF_ClockRead not supported' ) + end subroutine ESMF_ClockRead + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockWrite - Saves a clock + +! !INTERFACE: + subroutine ESMF_ClockWrite(clock, TimeStep, StartTime, StopTime, & + RefTime, CurrTime, PrevTime, AdvanceCount, & + AlarmList, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + type(ESMF_TimeInterval), intent(out) :: TimeStep + type(ESMF_Time), intent(out) :: StartTime + type(ESMF_Time), intent(out) :: StopTime + type(ESMF_Time), intent(out) :: RefTime + type(ESMF_Time), intent(out) :: CurrTime + type(ESMF_Time), intent(out) :: PrevTime + integer(ESMF_KIND_I8), intent(out) :: AdvanceCount + type(ESMF_Alarm), dimension(MAX_ALARMS), intent(out) :: AlarmList + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Save an {\tt ESMF\_Clock} +! +! The arguments are: +! \begin{description} +! \item[clock] +! The object instance to save +! \item[TimeStep] +! The {\tt ESMF\_Clock}'s time step interval +! \item[StartTime] +! The {\tt ESMF\_Clock}'s starting time +! \item[StopTime] +! The {\tt ESMF\_Clock}'s stopping time +! \item[RefTime] +! The {\tt ESMF\_Clock}'s reference time +! \item[CurrTime] +! The {\tt ESMF\_Clock}'s current time +! \item[PrevTime] +! The {\tt ESMF\_Clock}'s previous time +! \item[AdvanceCount] +! The number of times the {\tt ESMF\_Clock} has been advanced +! \item[AlarmList] +! The {\tt ESMF\_Clock}'s {\tt ESMF\_Alarm} list +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +!EOP + CALL wrf_error_fatal( 'ESMF_ClockWrite not supported' ) + end subroutine ESMF_ClockWrite + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockValidate - Validate a Clock's properties + +! !INTERFACE: + subroutine ESMF_ClockValidate(clock, opts, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! Perform a validation check on an {\tt ESMF\_Clock}'s properties +! +! The arguments are: +! \begin{description} +! \item[clock] +! {\tt ESMF\_Clock} to validate +! \item[{[opts]}] +! Validate options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + CALL wrf_error_fatal( 'ESMF_ClockValidate not supported' ) + end subroutine ESMF_ClockValidate + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_ClockPrint - Print out a Clock's properties + +! !INTERFACE: + subroutine ESMF_ClockPrint(clock, opts, rc) + +! !ARGUMENTS: + type(ESMF_Clock), intent(in) :: clock + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! To support testing/debugging, print out an {\tt ESMF\_Clock}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[clock] +! {\tt ESMF\_Clock} to print out +! \item[{[opts]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + type(ESMF_Time) :: start_time + type(ESMF_Time) :: stop_time + type(ESMF_Time) :: curr_time + type(ESMF_Time) :: ref_time + type(ESMF_TimeInterval) :: timestep + + call ESMF_ClockGet( clock, startTime=start_time, & + stoptime=stop_time, currTime=curr_time, & + refTime=ref_time, timeStep=timestep, rc=rc ) + print *, 'Start time: ' + call ESMF_TimePrint( start_time ) + print *, 'Stop time: ' + call ESMF_TimePrint( stop_time ) + print *, 'Reference time: ' + call ESMF_TimePrint( ref_time ) + print *, 'Current time: ' + call ESMF_TimePrint( curr_time ) + print *, 'Time step: ' + call ESMF_TimeIntervalPrint( timestep) + end subroutine ESMF_ClockPrint + +!------------------------------------------------------------------------------ + + end module ESMF_ClockMod diff --git a/share/esmf_wrf_timemgr/ESMF_FractionMod.F90 b/share/esmf_wrf_timemgr/ESMF_FractionMod.F90 new file mode 100644 index 000000000000..7f451f3d0cbd --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_FractionMod.F90 @@ -0,0 +1,85 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +! ESMF Fraction Module +! +!============================================================================== +! +! ESMF Fraction Module + module ESMF_FractionMod +! +!============================================================================== +! +! This file contains the Fraction class definition and all Fraction +! class methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +! +!=============================================================================== +!BOPI +! +! !MODULE: ESMF_FractionMod +! +! !DESCRIPTION: +! Part of ESMF F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ implementaion of class {\tt ESMC\_Fraction} +! +! See {\tt ../include/ESMC\_Fraction.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Fraction +! + type ESMF_Fraction + private + integer :: n ! Integer fraction (exact) n/d; numerator + integer :: d ! Integer fraction (exact) n/d; denominator + end type +! +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_Fraction +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: + +! !PRIVATE MEMBER FUNCTIONS: + +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== + +! contains + +!============================================================================== +! +! Wrappers to C++ fraction routines +! +!------------------------------------------------------------------------------ +! + +!------------------------------------------------------------------------------ + + end module ESMF_FractionMod diff --git a/share/esmf_wrf_timemgr/ESMF_Macros.inc b/share/esmf_wrf_timemgr/ESMF_Macros.inc new file mode 100644 index 000000000000..896190e742a7 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_Macros.inc @@ -0,0 +1,36 @@ +#if 0 +$Id$ + +Earth System Modeling Framework +Copyright 2002-2003, University Corporation for Atmospheric Research, +Massachusetts Institute of Technology, Geophysical Fluid Dynamics +Laboratory, University of Michigan, National Centers for Environmental +Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +NASA Goddard Space Flight Center. +Licensed under the GPL. + +Do not have C++ or F90 style comments in here because this file is processed +by both C++ and F90 compilers. + +These lines prevent this file from being read more than once if it +ends up being included multiple times. +#endif + +#ifndef ESMF_MACROS_INC +#define ESMF_MACROS_INC + +#if 0 + +former file contents moved to ESMF_BaseMod +so user code can be compiled without requiring +the preprocessor. + +#endif + +#if 0 +i left the following macro here in case it is needed for our internal use. +#endif + +#define ESMF_SRCLINE __FILE__, __LINE__ + +#endif diff --git a/share/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 b/share/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 new file mode 100644 index 000000000000..2a4364fac0f9 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_ShrTimeMod.F90 @@ -0,0 +1,45 @@ + module ESMF_ShrTimeMod +! +!============================================================================== +! +! This file contains types and methods that are shared in the hierarchy +! +!------------------------------------------------------------------------------ +! INCLUDES + +!============================================================================== +!BOPI +! !MODULE: ESMF_ShrTimeMod +! +! !DESCRIPTION: +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + use ESMF_CalendarMod + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Time +! +! ! F90 class type to match C++ Time class in size only; +! ! all dereferencing within class is performed by C++ implementation + + type ESMF_Time + type(ESMF_BaseTime) :: basetime ! inherit base class + ! time instant is expressed as year + basetime + integer :: YR + type(ESMF_Calendar), pointer :: calendar => null() ! associated calendar + end type + + public ESMF_Time +!============================================================================== +end module ESMF_ShrTimeMod diff --git a/share/esmf_wrf_timemgr/ESMF_Stubs.F90 b/share/esmf_wrf_timemgr/ESMF_Stubs.F90 new file mode 100644 index 000000000000..4c144e2bdcae --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_Stubs.F90 @@ -0,0 +1,154 @@ +! Various dummy type definitions and routines for the sole purpose of +! mimicking newer ESMF interface features without necessarily implementing +! them. + +MODULE ESMF_Stubs + + IMPLICIT NONE + + PRIVATE + +! Bogus typedefs + TYPE ESMF_Grid + INTEGER :: dummy + END TYPE + + TYPE ESMF_GridComp + INTEGER :: dummy + END TYPE + + TYPE ESMF_State + INTEGER :: dummy + END TYPE + + TYPE ESMF_VM + INTEGER :: dummy + END TYPE + + TYPE ESMF_END_FLAG + INTEGER :: dummy + END TYPE + TYPE(ESMF_END_FLAG), PARAMETER :: & + ESMF_END_ABORT = ESMF_END_FLAG(1), & + ESMF_END_NORMAL = ESMF_END_FLAG(2), & + ESMF_END_KEEPMPI = ESMF_END_FLAG(3) + + TYPE ESMF_MsgType + INTEGER :: mtype + END TYPE + TYPE(ESMF_MsgType), PARAMETER :: & + ESMF_LOG_INFO = ESMF_MsgType(1), & + ESMF_LOG_WARNING = ESMF_MsgType(2), & + ESMF_LOG_ERROR = ESMF_MsgType(3) + + TYPE ESMF_LOG + INTEGER :: dummy + END TYPE + + LOGICAL, private, save :: initialized = .false. + + PUBLIC ESMF_Grid, ESMF_GridComp, ESMF_State, ESMF_VM + PUBLIC ESMF_Initialize, ESMF_Finalize, ESMF_IsInitialized + PUBLIC ESMF_LogWrite, ESMF_LOG, ESMF_MsgType, ESMF_END_FLAG + PUBLIC ESMF_LOG_INFO, ESMF_LOG_WARNING, ESMF_LOG_ERROR + PUBLIC ESMF_END_ABORT, ESMF_END_NORMAL, ESMF_END_KEEPMPI + +CONTAINS + + +! NOOP + SUBROUTINE ESMF_Initialize( vm, defaultCalendar, rc ) + USE ESMF_BaseMod + USE ESMF_CalendarMod +! USE ESMF_TimeMod, only: defaultCal + TYPE(ESMF_VM), INTENT(IN ), OPTIONAL :: vm + TYPE(ESMF_CalKind_Flag), INTENT(IN ), OPTIONAL :: defaultCalendar + INTEGER, INTENT( OUT), OPTIONAL :: rc + + TYPE(ESMF_CalKind_Flag) :: defaultCalType + INTEGER :: status + + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + ! Initialize the default time manager calendar + IF ( PRESENT(defaultCalendar) )THEN + defaultCalType = defaultCalendar + ELSE + defaultCalType = ESMF_CALKIND_NOLEAP + END IF + allocate( defaultCal ) +! write(6,*) 'tcx1 ESMF_Stubs defcal ',defaultcaltype%caltype +! call flush(6) + defaultCal = ESMF_CalendarCreate( calkindflag=defaultCalType, & + rc=status) +! write(6,*) 'tcx2 ESMF_Stubs defcal ',defaultcal%type%caltype +! call flush(6) + allocate( gregorianCal ) +! write(6,*) 'tcx1 ESMF_Stubs grcal ',esmf_calkind_gregorian%caltype +! call flush(6) + gregorianCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_GREGORIAN, & + rc=status) +! write(6,*) 'tcx2 ESMF_Stubs grcal ',gregoriancal%type%caltype +! call flush(6) + allocate( noleapCal ) +! write(6,*) 'tcx1 ESMF_Stubs nlcal ',esmf_calkind_noleap%caltype +! call flush(6) + noleapCal = ESMF_CalendarCreate( calkindflag=ESMF_CALKIND_NOLEAP, & + rc=status) +! write(6,*) 'tcx2 ESMF_Stubs nlcal ',noleapcal%type%caltype +! call flush(6) + + ! initialize tables in time manager + CALL initdaym + + IF (status .ne. ESMF_SUCCESS) THEN + PRINT *, "Error initializing the default time manager calendar" + RETURN + END IF + initialized = .true. + + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + END SUBROUTINE ESMF_Initialize + + + FUNCTION ESMF_IsInitialized() + LOGICAL ESMF_IsInitialized + ESMF_IsInitialized = initialized + END FUNCTION ESMF_IsInitialized + + +! NOOP + SUBROUTINE ESMF_Finalize( endflag, rc ) + USE ESMF_BaseMod + type(ESMF_END_FLAG), intent(in), optional :: endflag + INTEGER, INTENT( OUT), OPTIONAL :: rc +#ifndef HIDE_MPI +#include +#endif + INTEGER :: ier + + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS +#ifndef HIDE_MPI + CALL MPI_Finalize( ier ) + IF ( ier .ne. mpi_success )THEN + IF ( PRESENT( rc ) ) rc = ESMF_FAILURE + END IF +#endif + END SUBROUTINE ESMF_Finalize + +! NOOP + SUBROUTINE ESMF_LogWrite( msg, MsgType, line, file, method, log, rc ) + USE ESMF_BaseMod + CHARACTER(LEN=*), INTENT(IN) :: msg + TYPE(ESMF_MsgType), INTENT(IN) :: msgtype + INTEGER, INTENT(IN), OPTIONAL :: line + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: file + CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: method + TYPE(ESMF_LOG),TARGET,OPTIONAL :: log + INTEGER, INTENT(OUT),OPTIONAL :: rc + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + END SUBROUTINE ESMF_LogWrite + + +END MODULE ESMF_Stubs + + diff --git a/share/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 b/share/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 new file mode 100644 index 000000000000..5d8be4e738cb --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_TimeIntervalMod.F90 @@ -0,0 +1,1688 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF TimeInterval Module + +module ESMF_TimeIntervalMod + +! +!============================================================================== +! +! This file contains the TimeInterval class definition and all TimeInterval +! class methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include +! +!=============================================================================== +!BOPI +! !MODULE: ESMF_TimeIntervalMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ implementaion of class {\tt ESMC\_TimeInterval} +! +! See {\tt ../include/ESMC\_TimeInterval.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + + ! associated derived types + use ESMF_FractionMod, only : ESMF_Fraction + use ESMF_CalendarMod + use ESMF_ShrTimeMod, only : ESMF_Time + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_TimeInterval +! +! ! F90 class type to match C++ TimeInterval class in size only; +! ! all dereferencing within class is performed by C++ implementation + + type ESMF_TimeInterval + ! time interval is expressed as basetime + type(ESMF_BaseTime) :: basetime ! inherit base class + ! Relative year and month fields support monthly or yearly time + ! intervals. Many operations are undefined when these fields are + ! non-zero! + INTEGER :: YR ! relative year + INTEGER :: MM ! relative month + logical :: starttime_set ! reference time set + type(ESMF_Time) :: starttime ! reference time + end type + +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_TimeInterval +!------------------------------------------------------------------------------ +! +! for running WRF, add three subroutines or functions (WRFADDITION_TimeIntervalGet, +! ESMF_TimeIntervalDIVQuot, ESMF_TimeIntervalIsPositive), by jhe +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_TimeIntervalGet + public ESMF_TimeIntervalSet + public ESMF_TimeIntervalAbsValue + public ESMF_TimeIntervalNegAbsValue + public ESMF_TimeIntervalPrint + public normalize_timeint + +! Required inherited and overridden ESMF_Base class methods + +!!!!!!!!! added by jhe + public ESMF_TimeIntervalDIVQuot + public ESMF_TimeIntervalIsPositive +! + +! !PRIVATE MEMBER FUNCTIONS: + +! overloaded operator functions + + public operator(/) + private ESMF_TimeIntervalQuotI + + public operator(*) + private ESMF_TimeIntervalProdI + +! Inherited and overloaded from ESMF_BaseTime + + public operator(+) + private ESMF_TimeIntervalSum + + public operator(-) + private ESMF_TimeIntervalDiff + + public operator(.EQ.) + private ESMF_TimeIntervalEQ + + public operator(.NE.) + private ESMF_TimeIntervalNE + + public operator(.LT.) + private ESMF_TimeIntervalLT + + public operator(.GT.) + private ESMF_TimeIntervalGT + + public operator(.LE.) + private ESMF_TimeIntervalLE + + public operator(.GE.) + private ESMF_TimeIntervalGE +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + +!============================================================================== +! +! INTERFACE BLOCKS +! +!============================================================================== +!BOP +! !INTERFACE: + interface operator(*) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalProdI + +! !DESCRIPTION: +! This interface overloads the * operator for the {\tt ESMF\_TimeInterval} +! class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(/) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalQuotI + +! !DESCRIPTION: +! This interface overloads the / operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(+) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalSum + +! !DESCRIPTION: +! This interface overloads the + operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(-) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalDiff + +! !DESCRIPTION: +! This interface overloads the - operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.EQ.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalEQ + +! !DESCRIPTION: +! This interface overloads the .EQ. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.NE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalNE + +! !DESCRIPTION: +! This interface overloads the .NE. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.LT.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalLT + +! !DESCRIPTION: +! This interface overloads the .LT. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.GT.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalGT + +! !DESCRIPTION: +! This interface overloads the .GT. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.LE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalLE + +! !DESCRIPTION: +! This interface overloads the .LE. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.GE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeIntervalGE + +! !DESCRIPTION: +! This interface overloads the .GE. operator for the +! {\tt ESMF\_TimeInterval} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ + +!============================================================================== + + contains + +!============================================================================== +! +! Generic Get/Set routines which use F90 optional arguments +! +!--------------------------------------------------------------------- +!BOP +! !IROUTINE: ESMF_TimeIntervalGet - Get value in user-specified units + +! !INTERFACE: + subroutine ESMF_TimeIntervalGet(timeinterval, StartTimeIn, yy, mm, D, d_r8, S, S_i8, Sn, Sd, TimeString, rc ) + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + type(ESMF_Time), optional, intent(in) :: StartTimeIn + integer, intent(out), optional :: yy + integer, intent(out), optional :: mm + integer, intent(out), optional :: D + real(ESMF_KIND_R8), intent(out), optional :: d_r8 + integer(ESMF_KIND_I8),intent(out), optional :: S_i8 + integer, intent(out), optional :: S + integer, intent(out), optional :: Sn + integer, intent(out), optional :: Sd + character*(*), optional, intent(out) :: TimeString + integer, intent(out), optional :: rc + + +! !DESCRIPTION: +! Get the value of the {\tt ESMF\_TimeInterval} in units specified by the +! user via F90 optional arguments. +! +! Time manager represents and manipulates time internally with integers +! to maintain precision. Hence, user-specified floating point values are +! converted internally from integers. +! +! See {\tt ../include/ESMC\_BaseTime.h} and +! {\tt ../include/ESMC\_TimeInterval.h} for complete description. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The object instance to query +! \item[{[YY]}] +! Integer years (>= 32-bit) +! \item[{[YYl]}] +! Integer years (large, >= 64-bit) +! \item[{[MO]}] +! Integer months (>= 32-bit) +! \item[{[MOl]}] +! Integer months (large, >= 64-bit) +! \item[{[D]}] +! Integer days (>= 32-bit) +! \item[{[Dl]}] +! Integer days (large, >= 64-bit) +! \item[{[H]}] +! Integer hours +! \item[{[M]}] +! Integer minutes +! \item[{[S]}] +! Integer seconds (>= 32-bit) +! \item[{[Sl]}] +! Integer seconds (large, >= 64-bit) +! \item[{[MS]}] +! Integer milliseconds +! \item[{[US]}] +! Integer microseconds +! \item[{[NS]}] +! Integer nanoseconds +! \item[{[d\_]}] +! Double precision days +! \item[{[h\_]}] +! Double precision hours +! \item[{[m\_]}] +! Double precision minutes +! \item[{[s\_]}] +! Double precision seconds +! \item[{[ms\_]}] +! Double precision milliseconds +! \item[{[us\_]}] +! Double precision microseconds +! \item[{[ns\_]}] +! Double precision nanoseconds +! \item[{[Sn]}] +! Integer fractional seconds - numerator +! \item[{[Sd]}] +! Integer fractional seconds - denominator +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG1.1 +!EOP + type(ESMF_Time) :: lstarttime + logical :: lstarttime_set + logical :: doyear + INTEGER(ESMF_KIND_I8) :: seconds, secondsym, years + INTEGER :: ierr + INTEGER :: mpyi4, iyr,imo,mmon,nmon,mstart,ndays + + ierr = ESMF_FAILURE + + if (present(StartTimeIn)) then + lstarttime_set = .true. + lstarttime = StartTimeIn + else + lstarttime_set = timeinterval%StartTime_set + lstarttime = timeinterval%StartTime + endif + + + CALL timeintchecknormalized( timeinterval, & + 'ESMF_TimeIntervalGet arg1', & + relative_interval=.true. ) + seconds = timeinterval%basetime%S + years = timeinterval%YR + + secondsym = 0 + + IF ( PRESENT( YY ) )THEN + YY = years + timeinterval%MM / MONTHS_PER_YEAR +! seconds = seconds - years * ( 365_ESMF_KIND_I8 * SECONDS_PER_DAY ) + IF ( PRESENT( MM ) )THEN + mpyi4 = MONTHS_PER_YEAR + MM = MOD( timeinterval%MM, mpyi4) + else + call wrf_error_fatal("ESMF_TimeIntervalGet: requires MM with YY") + END IF + ELSE IF ( PRESENT( MM ) )THEN + MM = timeinterval%MM + years*12 + else if (lstarttime_set) then + ! convert years and months to days carefully + + mpyi4 = MONTHS_PER_YEAR + mmon = timeinterval%mm + timeinterval%yr*mpyi4 + mstart = nmonthinyearsec(lstarttime%yr,lstarttime%basetime,lstarttime%calendar%type) +! write(6,*) 'tcxti1 ',mmon,lstarttime%yr,mstart,lstarttime%basetime%s + + iyr = lstarttime%yr + if (mmon > 0) then + imo = mstart-1 ! if adding months, start with this month after adding first +1 + else + imo = mstart ! if going backwards, start with last month after first -1 + endif + nmon = 1 +! do nmon = 1,abs(mmon) + do while (nmon <= abs(mmon)) + if (mmon > 0) then + if (imo == 12 .and. (abs(mmon) - nmon) > 12) then + iyr = iyr + 1 + nmon = nmon + 12 + doyear = .true. + else + imo = imo + 1 + nmon = nmon + 1 + doyear = .false. + endif + else + if (imo == 1 .and. (abs(mmon) - nmon) > 12) then + iyr = iyr - 1 + nmon = nmon + 12 + doyear = .true. + else + imo = imo - 1 + nmon = nmon + 1 + doyear = .false. + endif + endif + + do while (imo > 12) + imo = imo - 12 + iyr = iyr + 1 + enddo + do while (imo < 1) + imo = imo + 12 + iyr = iyr - 1 + enddo + + if (doyear) then + ndays = ndaysinyear(iyr,lstarttime%calendar%type) + else + ndays = ndaysinmonth(iyr,imo,lstarttime%calendar%type) + endif + secondsym = secondsym + (ndays * SECONDS_PER_DAY) +! write(6,*) 'tcxti2 ',nmon,iyr,imo,ndays + enddo + if (mmon < 0) then + secondsym = -secondsym + endif +! write(6,*) 'tcxti3 ',mmon,iyr,imo,secondsym + elseif (PRESENT(D) .or. PRESENT(d_r8) .or. present(S) .or. present(S_i8)) then + IF (timeinterval%MM /= 0) then + CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need MM with D,d_r8,S,or S_i8") + endif + if (timeinterval%YR /= 0) then + CALL wrf_error_fatal("ESMF_TimeIntervalGet: Need YY or MM with D,d_r8,S,or S_i8") + endif + END IF + + seconds = seconds+secondsym + + IF ( PRESENT( D ) )THEN + D = seconds / SECONDS_PER_DAY + IF ( PRESENT(S) ) S = mod( seconds, SECONDS_PER_DAY ) + IF ( PRESENT(S_i8)) S_i8 = mod( seconds, SECONDS_PER_DAY ) + ELSE + IF ( PRESENT(S) ) S = seconds + IF ( PRESENT(S_i8)) S_i8 = seconds + END IF + + IF ( PRESENT( d_r8 ) )THEN + D_r8 = REAL( seconds, ESMF_KIND_R8 ) / & + REAL( SECONDS_PER_DAY, ESMF_KIND_R8 ) + END IF + + ! If d_r8 present and sec present + IF ( PRESENT( d_r8 ) )THEN + IF ( PRESENT( S ) .or. present(s_i8) )THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalGet: Can not specify d_r8 and S S_i8 values" ) + END IF + END IF + + ierr = ESMF_SUCCESS + + IF ( PRESENT( timeString ) ) THEN + CALL ESMFold_TimeIntervalGetString( timeinterval, timeString, rc=ierr ) + ENDIF + + IF ( PRESENT(Sn) ) THEN + Sn = timeinterval%basetime%Sn + ENDIF + IF ( PRESENT(Sd) ) THEN + Sd = timeinterval%basetime%Sd + ENDIF + + IF ( PRESENT(rc) ) rc = ierr + + end subroutine ESMF_TimeIntervalGet + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalSet - Initialize via user-specified unit set + +! !INTERFACE: +! subroutine ESMF_TimeIntervalSet(timeinterval, YY, YYl, MM, MOl, D, Dl, & +! H, M, S, Sl, MS, US, NS, & +! d_, d_r8, h_, m_, s_, ms_, us_, ns_, & +! Sn, Sd, startTime, rc) + subroutine ESMF_TimeIntervalSet(timeinterval, YY, MM, D, & + H, M, S, S_i8, MS, & + d_, d_r8, & + Sn, Sd, startTime, rc) + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(out) :: timeinterval + type(ESMF_Time), intent(in), optional :: StartTime + integer, intent(in), optional :: YY +! integer(ESMF_KIND_I8), intent(in), optional :: YYl + integer, intent(in), optional :: MM +! integer(ESMF_KIND_I8), intent(in), optional :: MOl + integer, intent(in), optional :: D +! integer(ESMF_KIND_I8), intent(in), optional :: Dl + integer, intent(in), optional :: H + integer, intent(in), optional :: M + integer, intent(in), optional :: S + integer(ESMF_KIND_I8), intent(in), optional :: S_i8 + integer, intent(in), optional :: MS +! integer, intent(in), optional :: US +! integer, intent(in), optional :: NS + double precision, intent(in), optional :: d_ + double precision, intent(in), optional :: d_r8 +! double precision, intent(in), optional :: h_ +! double precision, intent(in), optional :: m_ +! double precision, intent(in), optional :: s_ +! double precision, intent(in), optional :: ms_ +! double precision, intent(in), optional :: us_ +! double precision, intent(in), optional :: ns_ + integer, intent(in), optional :: Sn + integer, intent(in), optional :: Sd + integer, intent(out), optional :: rc + ! locals + double precision :: din + logical :: dinset + +! !DESCRIPTION: +! Set the value of the {\tt ESMF\_TimeInterval} in units specified by +! the user via F90 optional arguments +! +! Time manager represents and manipulates time internally with integers +! to maintain precision. Hence, user-specified floating point values are +! converted internally to integers. +! +! See {\tt ../include/ESMC\_BaseTime.h} and +! {\tt ../include/ESMC\_TimeInterval.h} for complete description. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The object instance to initialize +! \item[{[YY]}] +! Integer number of interval years (>= 32-bit) +! \item[{[YYl]}] +! Integer number of interval years (large, >= 64-bit) +! \item[{[MM]}] +! Integer number of interval months (>= 32-bit) +! \item[{[MOl]}] +! Integer number of interval months (large, >= 64-bit) +! \item[{[D]}] +! Integer number of interval days (>= 32-bit) +! \item[{[Dl]}] +! Integer number of interval days (large, >= 64-bit) +! \item[{[H]}] +! Integer hours +! \item[{[M]}] +! Integer minutes +! \item[{[S]}] +! Integer seconds (>= 32-bit) +! \item[{[Sl]}] +! Integer seconds (large, >= 64-bit) +! \item[{[MS]}] +! Integer milliseconds +! \item[{[US]}] +! Integer microseconds +! \item[{[NS]}] +! Integer nanoseconds +! \item[{[d\_]}] +! Double precision days +! \item[{[h\_]}] +! Double precision hours +! \item[{[m\_]}] +! Double precision minutes +! \item[{[s\_]}] +! Double precision seconds +! \item[{[ms\_]}] +! Double precision milliseconds +! \item[{[us\_]}] +! Double precision microseconds +! \item[{[ns\_]}] +! Double precision nanoseconds +! \item[{[Sn]}] +! Integer fractional seconds - numerator +! \item[{[Sd]}] +! Integer fractional seconds - denominator +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + + IF ( PRESENT(rc) ) rc = ESMF_FAILURE + + timeinterval%startTime_set = .false. + if (present(startTime)) then + timeinterval%startTime = startTime + timeinterval%startTime_set = .true. + endif + + ! note that YR and MM are relative + timeinterval%YR = 0 + IF ( PRESENT( YY ) ) THEN + timeinterval%YR = YY + ENDIF + timeinterval%MM = 0 + IF ( PRESENT( MM ) ) THEN + timeinterval%MM = MM + ENDIF + + if (present(d_) .and. present(d_r8)) then + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Cannot specify both d_r8 and d_") + endif + dinset = .false. + if (present(d_)) then + din = d_ + dinset = .true. + endif + if (present(d_r8)) then + din = d_r8 + dinset = .true. + endif + IF ( dinset .AND. PRESENT( D ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Cannot specify both D and d_ or d_r8") + ENDIF + + timeinterval%basetime%S = 0 + IF ( .NOT. dinset ) THEN + IF ( PRESENT( D ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_DAY * INT( D, ESMF_KIND_I8 ) ) + ENDIF +!$$$ push H,M,S,Sn,Sd,MS down into BaseTime constructor + IF ( PRESENT( H ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( M ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( S ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + INT( S, ESMF_KIND_I8 ) + ENDIF + IF ( PRESENT( S_i8 ) ) THEN + timeinterval%basetime%S = timeinterval%basetime%S + & + ( S_i8) + ENDIF + ELSE + timeinterval%basetime%S = timeinterval%basetime%S + & + INT( din * SECONDS_PER_DAY, ESMF_KIND_I8 ) + ENDIF + IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Must specify Sd if Sn is specified") + ENDIF + IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeIntervalSet: Must not specify both Sd and MS") + ENDIF + timeinterval%basetime%Sn = 0 + timeinterval%basetime%Sd = 0 + IF ( PRESENT( MS ) ) THEN + timeinterval%basetime%Sn = MS + timeinterval%basetime%Sd = 1000_ESMF_KIND_I8 + ELSE IF ( PRESENT( Sd ) ) THEN + timeinterval%basetime%Sd = Sd + IF ( PRESENT( Sn ) ) THEN + timeinterval%basetime%Sn = Sn + ENDIF + ENDIF + CALL normalize_timeint( timeinterval ) + + IF ( PRESENT(rc) ) rc = ESMF_SUCCESS + + end subroutine ESMF_TimeIntervalSet + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMFold_TimeIntervalGetString - Get time interval value in string format + +! !INTERFACE: + subroutine ESMFold_TimeIntervalGetString(timeinterval, TimeString, rc) + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + character*(*), intent(out) :: TimeString + integer, intent(out), optional :: rc + ! locals +! integer :: signnormtimeint + LOGICAL :: negative + INTEGER(ESMF_KIND_I8) :: iS, iSn, iSd, H, M, S, MM, D, YY + character (len=1) :: signstr + +! !DESCRIPTION: +! Convert {\tt ESMF\_TimeInterval}'s value into string format +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The object instance to convert +! \item[TimeString] +! The string to return +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.9 +!EOP + +! NOTE: Sn, and Sd are not yet included in the returned string... +!PRINT *,'DEBUG ESMFold_TimeIntervalGetString(): YR,MM,S,Sn,Sd = ', & +! timeinterval%YR, & +! timeinterval%MM, & +! timeinterval%basetime%S, & +! timeinterval%basetime%Sn, & +! timeinterval%basetime%Sd + + negative = ( signnormtimeint( timeInterval ) == -1 ) + IF ( negative ) THEN + iS = -timeinterval%basetime%S + iSn = -timeinterval%basetime%Sn + signstr = '-' + ELSE + iS = timeinterval%basetime%S + iSn = timeinterval%basetime%Sn + signstr = '' + ENDIF + iSd = timeinterval%basetime%Sd + + D = iS / SECONDS_PER_DAY + H = mod( iS, SECONDS_PER_DAY ) / SECONDS_PER_HOUR + M = mod( iS, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE + S = mod( iS, SECONDS_PER_MINUTE ) + +!$$$here... need to print Sn and Sd when they are used ??? + + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalGetString-arg1', & + relative_interval=.true. ) + IF ( (timeinterval%MM == 0) .AND. (timeinterval%YR == 0) )THEN + write(TimeString,FMT="(A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + TRIM(signstr), D, H, M, S + ELSEif (timeinterval%YR == 0) then + MM = timeinterval%MM + write(TimeString,FMT="(I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + MM, TRIM(signstr), D, H, M, S + else + YY = timeinterval%YR + MM = timeinterval%MM + write(TimeString,FMT="(I6.6,'_Years_',I4.4, '_Months_',A,I10.10,'_',I3.3,':',I3.3,':',I3.3)") & + YY, MM, TRIM(signstr), D, H, M, S + END IF + +!write(0,*)'TimeIntervalGetString Sn ',timeinterval%basetime%Sn,' Sd ',timeinterval%basetime%Sd + + rc = ESMF_SUCCESS + + end subroutine ESMFold_TimeIntervalGetString + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalAbsValue - Get the absolute value of a time interval + +! !INTERFACE: + function ESMF_TimeIntervalAbsValue(timeinterval) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalAbsValue + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval +! !LOCAL: + integer :: rc + +! !DESCRIPTION: +! Return a {\tt ESMF\_TimeInterval}'s absolute value. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The object instance to take the absolute value of. +! Absolute value returned as value of function. +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.8 +!EOP + ESMF_TimeIntervalAbsValue = timeinterval +!$$$here... move implementation into BaseTime + ESMF_TimeIntervalAbsValue%basetime%S = & + abs(ESMF_TimeIntervalAbsValue%basetime%S) + ESMF_TimeIntervalAbsValue%basetime%Sn = & + abs(ESMF_TimeIntervalAbsValue%basetime%Sn ) + ! + ESMF_TimeIntervalAbsValue%MM = & + abs(ESMF_TimeIntervalAbsValue%MM) + ESMF_TimeIntervalAbsValue%YR = & + abs(ESMF_TimeIntervalAbsValue%YR) + + end function ESMF_TimeIntervalAbsValue + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalNegAbsValue - Get the negative absolute value of a time interval + +! !INTERFACE: + function ESMF_TimeIntervalNegAbsValue(timeinterval) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalNegAbsValue + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval +! !LOCAL: + integer :: rc + +! !DESCRIPTION: +! Return a {\tt ESMF\_TimeInterval}'s negative absolute value. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The object instance to take the negative absolute value of. +! Negative absolute value returned as value of function. +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.8 +!EOP + ESMF_TimeIntervalNegAbsValue = timeinterval +!$$$here... move implementation into BaseTime + ESMF_TimeIntervalNegAbsValue%basetime%S = & + -abs(ESMF_TimeIntervalNegAbsValue%basetime%S) + ESMF_TimeIntervalNegAbsValue%basetime%Sn = & + -abs(ESMF_TimeIntervalNegAbsValue%basetime%Sn ) + ! + ESMF_TimeIntervalNegAbsValue%MM = & + -abs(ESMF_TimeIntervalNegAbsValue%MM ) + ESMF_TimeIntervalNegAbsValue%YR = & + -abs(ESMF_TimeIntervalNegAbsValue%YR ) + + end function ESMF_TimeIntervalNegAbsValue + +!------------------------------------------------------------------------------ +! +! This section includes overloaded operators defined only for TimeInterval +! (not inherited from BaseTime) +! Note: these functions do not have a return code, since F90 forbids more +! than 2 arguments for arithmetic overloaded operators +! +!------------------------------------------------------------------------------ + +! new WRF-specific function, Divide two time intervals and return the whole integer, without remainder + function ESMF_TimeIntervalDIVQuot(timeinterval1, timeinterval2) + +! !RETURN VALUE: + INTEGER :: ESMF_TimeIntervalDIVQuot + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !LOCAL + INTEGER :: retval, isgn, rc + type(ESMF_TimeInterval) :: zero, i1,i2 + +! !DESCRIPTION: +! Returns timeinterval1 divided by timeinterval2 as a fraction quotient. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! The dividend +! \item[timeinterval2] +! The divisor +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.5 +!EOP + + CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDIVQuot arg1' ) + CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDIVQuot arg2' ) + + call ESMF_TimeIntervalSet( zero, rc=rc ) + i1 = timeinterval1 + i2 = timeinterval2 + isgn = 1 + if ( i1 .LT. zero ) then + i1 = WRFADDITION_TimeIntervalProdI(i1, -1) + isgn = -isgn + endif + if ( i2 .LT. zero ) then + i2 = WRFADDITION_TimeIntervalProdI(i2, -1) + isgn = -isgn + endif +! repeated subtraction + retval = 0 + DO WHILE ( i1 .GE. i2 ) + i1 = i1 - i2 + retval = retval + 1 + ENDDO + retval = retval * isgn + + ESMF_TimeIntervalDIVQuot = retval + + end function ESMF_TimeIntervalDIVQuot +! added by jhe +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: WRFADDITION_TimeIntervalProdI - Multiply a time interval by an +! integer + +! !INTERFACE: + function WRFADDITION_TimeIntervalProdI(timeinterval, multiplier) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: WRFADDITION_TimeIntervalProdI + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + integer, intent(in) :: multiplier +! !LOCAL: + integer :: rc + +! !DESCRIPTION: +! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product +! as a +! {\tt ESMF\_TimeInterval} +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The multiplicand +! \item[mutliplier] +! Integer multiplier +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.7, TMG7.2 +!EOP + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdICarg1') + + CALL ESMF_TimeIntervalSet( WRFADDITION_TimeIntervalProdI, rc=rc ) +!$$$move this into overloaded operator(*) in BaseTime + WRFADDITION_TimeIntervalProdI%basetime%S = & + timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 ) + WRFADDITION_TimeIntervalProdI%basetime%Sn = & + timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) + ! Don't multiply Sd + WRFADDITION_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd + CALL normalize_timeint( WRFADDITION_TimeIntervalProdI ) + + end function WRFADDITION_TimeIntervalProdI + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalQuotI - Divide time interval by an integer, return time interval result + +! !INTERFACE: + function ESMF_TimeIntervalQuotI(timeinterval, divisor) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalQuotI + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + integer, intent(in) :: divisor + +! !DESCRIPTION: +! Divides a {\tt ESMF\_TimeInterval} by an integer divisor, returns +! quotient as a {\tt ESMF\_TimeInterval} +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The dividend +! \item[divisor] +! Integer divisor +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.6, TMG5.3, TMG7.2 +!EOP + +!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A: S,Sn,Sd = ', & +! timeinterval%basetime%S,timeinterval%basetime%Sn,timeinterval%basetime%Sd +!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() A: divisor = ', divisor + + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalQuotI arg1' ) + + IF ( divisor == 0 ) THEN + CALL wrf_error_fatal( 'ESMF_TimeIntervalQuotI: divide by zero' ) + ENDIF + ESMF_TimeIntervalQuotI = timeinterval +!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() B: S,Sn,Sd = ', & +! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd + ESMF_TimeIntervalQuotI%basetime = timeinterval%basetime / divisor +!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() C: S,Sn,Sd = ', & +! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd + + CALL normalize_timeint( ESMF_TimeIntervalQuotI ) +!PRINT *,'DEBUG ESMF_TimeIntervalQuotI() D: S,Sn,Sd = ', & +! ESMF_TimeIntervalQuotI%basetime%S,ESMF_TimeIntervalQuotI%basetime%Sn,ESMF_TimeIntervalQuotI%basetime%Sd + + end function ESMF_TimeIntervalQuotI + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalProdI - Multiply a time interval by an integer + +! !INTERFACE: + function ESMF_TimeIntervalProdI(timeinterval, multiplier) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalProdI + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + integer, intent(in) :: multiplier +! !LOCAL: + integer :: rc + +! !DESCRIPTION: +! Multiply a {\tt ESMF\_TimeInterval} by an integer, return product as a +! {\tt ESMF\_TimeInterval} +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! The multiplicand +! \item[mutliplier] +! Integer multiplier +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.7, TMG7.2 +!EOP + CALL timeintchecknormalized( timeinterval, 'ESMF_TimeIntervalProdI arg1', & + relative_interval=.true. ) + + CALL ESMF_TimeIntervalSet( ESMF_TimeIntervalProdI, rc=rc ) +!$$$move this into overloaded operator(*) in BaseTime + ESMF_TimeIntervalProdI%basetime%S = & + timeinterval%basetime%S * INT( multiplier, ESMF_KIND_I8 ) + ESMF_TimeIntervalProdI%basetime%Sn = & + timeinterval%basetime%Sn * INT( multiplier, ESMF_KIND_I8 ) + ! Don't multiply Sd + ESMF_TimeIntervalProdI%basetime%Sd = timeinterval%basetime%Sd + ESMF_TimeIntervalProdI%MM = timeinterval%MM * multiplier + ESMF_TimeIntervalProdI%YR = timeinterval%YR * multiplier + CALL normalize_timeint( ESMF_TimeIntervalProdI ) + + end function ESMF_TimeIntervalProdI + +!------------------------------------------------------------------------------ +! +! This section includes the inherited ESMF_BaseTime class overloaded operators +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalSum - Add two time intervals together + +! !INTERFACE: + function ESMF_TimeIntervalSum(timeinterval1, timeinterval2) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalSum + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 +! !LOCAL: + integer :: rc +! !DESCRIPTION: +! Add two {\tt ESMF\_TimeIntervals}, return sum as a +! {\tt ESMF\_TimeInterval}. Maps overloaded (+) operator interface +! function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! The augend +! \item[timeinterval2] +! The addend +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, +! TMG7.2 +!EOP + CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalSum arg1', & + relative_interval=.true. ) + CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalSum arg2', & + relative_interval=.true. ) + + ESMF_TimeIntervalSum = timeinterval1 + ESMF_TimeIntervalSum%basetime = ESMF_TimeIntervalSum%basetime + & + timeinterval2%basetime + ESMF_TimeIntervalSum%MM = ESMF_TimeIntervalSum%MM + & + timeinterval2%MM + ESMF_TimeIntervalSum%YR = ESMF_TimeIntervalSum%YR + & + timeinterval2%YR + + CALL normalize_timeint( ESMF_TimeIntervalSum ) + + end function ESMF_TimeIntervalSum + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalDiff - Subtract one time interval from another + +! !INTERFACE: + function ESMF_TimeIntervalDiff(timeinterval1, timeinterval2) + +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeIntervalDiff + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 +! !LOCAL: + integer :: rc +! !DESCRIPTION: +! Subtract timeinterval2 from timeinterval1, return remainder as a +! {\tt ESMF\_TimeInterval}. +! Map overloaded (-) operator interface function to {\tt ESMF\_BaseTime} +! base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! The minuend +! \item[timeinterval2] +! The subtrahend +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 +!EOP + CALL timeintchecknormalized( timeinterval1, 'ESMF_TimeIntervalDiff arg1', & + relative_interval=.true. ) + CALL timeintchecknormalized( timeinterval2, 'ESMF_TimeIntervalDiff arg2', & + relative_interval=.true. ) + + ESMF_TimeIntervalDiff = timeinterval1 + ESMF_TimeIntervalDiff%basetime = ESMF_TimeIntervalDiff%basetime - & + timeinterval2%basetime + ESMF_TimeIntervalDiff%MM = ESMF_TimeIntervalDiff%MM - & + timeinterval2%MM + ESMF_TimeIntervalDiff%YR = ESMF_TimeIntervalDiff%YR - & + timeinterval2%YR + CALL normalize_timeint( ESMF_TimeIntervalDiff ) + + end function ESMF_TimeIntervalDiff + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalEQ - Compare two time intervals for equality + +! !INTERFACE: + function ESMF_TimeIntervalEQ(timeinterval1, timeinterval2) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalEQ + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +!DESCRIPTION: +! Return true if both given time intervals are equal, false otherwise. +! Maps overloaded (==) operator interface function to {\tt ESMF\_BaseTime} +! base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalEQ = (res .EQ. 0) + + end function ESMF_TimeIntervalEQ + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalNE - Compare two time intervals for inequality + +! !INTERFACE: + function ESMF_TimeIntervalNE(timeinterval1, timeinterval2) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalNE + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !DESCRIPTION: +! Return true if both given time intervals are not equal, false otherwise. +! Maps overloaded (/=) operator interface function to {\tt ESMF\_BaseTime} +! base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalNE = (res .NE. 0) + + end function ESMF_TimeIntervalNE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalLT - Time interval 1 less than time interval 2 ? + +! !INTERFACE: + function ESMF_TimeIntervalLT(timeinterval1, timeinterval2) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalLT + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !DESCRIPTION: +! Return true if first time interval is less than second time interval, +! false otherwise. Maps overloaded (<) operator interface function to +! {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalLT = (res .LT. 0) + + end function ESMF_TimeIntervalLT + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalGT - Time interval 1 greater than time interval 2? + +! !INTERFACE: + function ESMF_TimeIntervalGT(timeinterval1, timeinterval2) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalGT + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !DESCRIPTION: +! Return true if first time interval is greater than second time interval, +! false otherwise. Maps overloaded (>) operator interface function to +! {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalGT = (res .GT. 0) + + end function ESMF_TimeIntervalGT + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalLE - Time interval 1 less than or equal to time interval 2 ? + +! !INTERFACE: + function ESMF_TimeIntervalLE(timeinterval1, timeinterval2) + +! !RETURN VALUE: + logical :: ESMF_TimeIntervalLE + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !DESCRIPTION: +! Return true if first time interval is less than or equal to second time +! interval, false otherwise. +! Maps overloaded (<=) operator interface function to {\tt ESMF\_BaseTime} +! base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalLE = (res .LE. 0) + + end function ESMF_TimeIntervalLE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalGE - Time interval 1 greater than or equal to time interval 2 ? + +! !INTERFACE: + function ESMF_TimeIntervalGE(timeinterval1, timeinterval2) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalGE + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval1 + type(ESMF_TimeInterval), intent(in) :: timeinterval2 + +! !DESCRIPTION: +! Return true if first time interval is greater than or equal to second +! time interval, false otherwise. Maps overloaded (>=) operator interface +! function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[timeinterval1] +! First time interval to compare +! \item[timeinterval2] +! Second time interval to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + INTEGER :: res + + CALL timeintcmp(timeinterval1,timeinterval2,res) + ESMF_TimeIntervalGE = (res .GE. 0) + + end function ESMF_TimeIntervalGE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalIsPositive - Time interval greater than zero? + +! !INTERFACE: + function ESMF_TimeIntervalIsPositive(timeinterval) +! +! !RETURN VALUE: + logical :: ESMF_TimeIntervalIsPositive + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + +! !LOCALS: + type(ESMF_TimeInterval) :: zerotimeint + integer :: rcint + +! !DESCRIPTION: +! Return true if time interval is greater than zero, +! false otherwise. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! Time interval to compare +! \end{description} +!EOP + CALL timeintchecknormalized( timeinterval, & + 'ESMF_TimeIntervalIsPositive arg' ) + + CALL ESMF_TimeIntervalSet ( zerotimeint, rc=rcint ) + IF ( rcint /= ESMF_SUCCESS ) THEN + CALL wrf_error_fatal( & + 'ESMF_TimeIntervalIsPositive: ESMF_TimeIntervalSet failed' ) + ENDIF +! hack for bug in PGI 5.1-x +! ESMF_TimeIntervalIsPositive = timeinterval > zerotimeint + ESMF_TimeIntervalIsPositive = ESMF_TimeIntervalGT( timeinterval, & + zerotimeint ) + end function ESMF_TimeIntervalIsPositive + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeIntervalPrint - Print out a time interval's properties + +! !INTERFACE: + subroutine ESMF_TimeIntervalPrint(timeinterval, opts, rc) + +! !ARGUMENTS: + type(ESMF_TimeInterval), intent(in) :: timeinterval + character (len=*), intent(in), optional :: opts + integer, intent(out), optional :: rc + +! !DESCRIPTION: +! To support testing/debugging, print out an {\tt ESMF\_TimeInterval}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[timeinterval] +! Time interval to print out +! \item[{[opts]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + INTEGER :: ierr + + ierr = ESMF_SUCCESS + call print_a_timeinterval( timeinterval ) + IF ( PRESENT(rc) ) rc = ierr + + end subroutine ESMF_TimeIntervalPrint + +!------------------------------------------------------------------------------ + +! Exits with error message if timeInt is not normalized. +SUBROUTINE timeintchecknormalized( timeInt, msgstr, relative_interval ) + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt + CHARACTER(LEN=*), INTENT(IN) :: msgstr + LOGICAL, INTENT(IN), optional :: relative_interval ! If relative intervals are ok or not + ! locals + CHARACTER(LEN=256) :: outstr + LOGICAL :: non_relative + + IF ( .NOT. PRESENT( relative_interval ) )THEN + non_relative = .true. + ELSE + IF ( relative_interval )THEN + non_relative = .false. + ELSE + non_relative = .true. + END IF + END IF + IF ( non_relative )THEN + IF ( ( timeInt%YR /= 0 ) .OR. & + ( timeInt%MM /= 0 ) ) THEN + outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) + CALL wrf_error_fatal( outstr ) + ENDIF + ELSE + IF ( ( timeInt%YR /= 0 ) .OR. & + ( timeInt%MM < -MONTHS_PER_YEAR) .OR. ( timeInt%MM > MONTHS_PER_YEAR ) ) THEN +! tcraig, don't require normalize TimeInterval for relative diffs +! outstr = 'un-normalized TimeInterval not allowed: '//TRIM(msgstr) +! CALL wrf_error_fatal( outstr ) + ENDIF + END IF +END SUBROUTINE timeintchecknormalized + +!============================================================================== +SUBROUTINE print_a_timeinterval( time ) + IMPLICIT NONE + type(ESMF_TimeInterval) time + character*128 :: s + integer rc + CALL ESMFold_TimeIntervalGetString( time, s, rc ) + write(6,*)'Print a time interval|',time%yr, time%mm, time%basetime%s, time%starttime_set, time%starttime%calendar%type%caltype + write(6,*)'Print a time interval|',TRIM(s),'|' + return +END SUBROUTINE print_a_timeinterval + +!============================================================================== + +SUBROUTINE timeintcmp(timeint1in, timeint2in, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint1in + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeint2in + + TYPE(ESMF_TimeInterval) :: timeint1 + TYPE(ESMF_TimeInterval) :: timeint2 + + timeint1 = timeint1in + timeint2 = timeint2in + call normalize_timeint(timeint1) + call normalize_timeint(timeint2) + + IF ( (timeint1%MM /= timeint2%MM) .and. (timeint1%YR /= timeint2%YR) )THEN + CALL wrf_error_fatal( & + 'timeintcmp: Can not compare two intervals with different months and years' ) + END IF + if (timeint1%YR .gt. timeint2%YR) then + retval = 1 + elseif (timeint1%YR .lt. timeint2%YR) then + retval = -1 + else + if (timeint1%MM .gt. timeint2%MM) then + retval = 1 + elseif (timeint1%MM .lt. timeint2%MM) then + retval = 1 + else + CALL seccmp( timeint1%basetime%S, timeint1%basetime%Sn, & + timeint1%basetime%Sd, & + timeint2%basetime%S, timeint2%basetime%Sn, & + timeint2%basetime%Sd, retval ) + endif + endif + +END SUBROUTINE timeintcmp + +!============================================================================== + +SUBROUTINE normalize_timeint( timeInt ) + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(INOUT) :: timeInt + INTEGER :: mpyi4 + + ! normalize basetime + ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match + ! YR and MM are ignored + + CALL normalize_basetime( timeInt%basetime ) + + ! Rollover months to years + + mpyi4 = MONTHS_PER_YEAR + IF ( abs(timeInt%MM) .GE. MONTHS_PER_YEAR ) THEN + timeInt%YR = timeInt%YR + timeInt%MM/MONTHS_PER_YEAR + timeInt%MM = mod(timeInt%MM,mpyi4) + ENDIF + + ! make sure yr and mm have same sign + + IF (timeInt%YR * timeInt%MM < 0) then + if (timeInt%YR > 0) then + timeInt%MM = timeInt%MM + MONTHS_PER_YEAR + timeInt%YR = timeInt%YR - 1 + endif + if (timeInt%YR < 0) then + timeInt%MM = timeInt%MM - MONTHS_PER_YEAR + timeInt%YR = timeInt%YR + 1 + endif + endif + +END SUBROUTINE normalize_timeint + +!============================================================================== + +integer FUNCTION signnormtimeint ( timeInt ) + ! Compute the sign of a time interval. + ! YR and MM fields are *IGNORED*. + ! returns 1, 0, or -1 or exits if timeInt fields have inconsistent signs. + IMPLICIT NONE + TYPE(ESMF_TimeInterval), INTENT(IN) :: timeInt + LOGICAL :: positive, negative + + positive = .FALSE. + negative = .FALSE. + signnormtimeint = 0 + ! Note that Sd is required to be non-negative. This is enforced in + ! normalize_timeint(). + ! Note that Sn is required to be zero when Sd is zero. This is enforced + ! in normalize_timeint(). + IF ( ( timeInt%basetime%S > 0 ) .OR. & + ( timeInt%basetime%Sn > 0 ) ) THEN + positive = .TRUE. + ENDIF + IF ( ( timeInt%basetime%S < 0 ) .OR. & + ( timeInt%basetime%Sn < 0 ) ) THEN + negative = .TRUE. + ENDIF + IF ( positive .AND. negative ) THEN + CALL wrf_error_fatal( & + 'signnormtimeint: signs of fields cannot be mixed' ) + ELSE IF ( positive ) THEN + signnormtimeint = 1 + ELSE IF ( negative ) THEN + signnormtimeint = -1 + ENDIF +END FUNCTION signnormtimeint +!============================================================================== + +end module ESMF_TimeIntervalMod + diff --git a/share/esmf_wrf_timemgr/ESMF_TimeMgr.inc b/share/esmf_wrf_timemgr/ESMF_TimeMgr.inc new file mode 100644 index 000000000000..e41a1f8514d6 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_TimeMgr.inc @@ -0,0 +1,45 @@ +#if 0 +$Id$ + +Earth System Modeling Framework +Copyright 2002-2003, University Corporation for Atmospheric Research, +Massachusetts Institute of Technology, Geophysical Fluid Dynamics +Laboratory, University of Michigan, National Centers for Environmental +Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +NASA Goddard Space Flight Center. +Licensed under the GPL. + +Do not have C++ or F90 style comments in here because this file is processed +by both C++ and F90 compilers. +#endif + +#ifndef ESMF_TimeMgr_INC +#define ESMF_TimeMgr_INC + +#if 0 +!BOP +------------------------------------------------------------------------- + + !DESCRIPTION: + + ESMF TimeMgr include file for F90 + The code in this file implements constants and macros for the TimeMgr... + +------------------------------------------------------------------------- +!EOP +#endif + +#include + +#define SECONDS_PER_DAY 86400_ESMF_KIND_I8 +#define SECONDS_PER_HOUR 3600_ESMF_KIND_I8 +#define SECONDS_PER_MINUTE 60_ESMF_KIND_I8 +#define HOURS_PER_DAY 24_ESMF_KIND_I8 +#define MONTHS_PER_YEAR 12_ESMF_KIND_I8 + +! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in +! ../../frame/module_domain.F !!! Eliminate this dependence with +! grow-as-you-go AlarmList in ESMF_Clock... +#define MAX_ALARMS 60 + +#endif diff --git a/share/esmf_wrf_timemgr/ESMF_TimeMod.F90 b/share/esmf_wrf_timemgr/ESMF_TimeMod.F90 new file mode 100644 index 000000000000..e68470aaaff1 --- /dev/null +++ b/share/esmf_wrf_timemgr/ESMF_TimeMod.F90 @@ -0,0 +1,1570 @@ +! $Id$ +! +! Earth System Modeling Framework +! Copyright 2002-2003, University Corporation for Atmospheric Research, +! Massachusetts Institute of Technology, Geophysical Fluid Dynamics +! Laboratory, University of Michigan, National Centers for Environmental +! Prediction, Los Alamos National Laboratory, Argonne National Laboratory, +! NASA Goddard Space Flight Center. +! Licensed under the GPL. +! +!============================================================================== +! +! ESMF Time Module + module ESMF_TimeMod +! +!============================================================================== +! +! This file contains the Time class definition and all Time class methods. +! +!------------------------------------------------------------------------------ +! INCLUDES +#include + +!============================================================================== +!BOPI +! !MODULE: ESMF_TimeMod +! +! !DESCRIPTION: +! Part of Time Manager F90 API wrapper of C++ implemenation +! +! Defines F90 wrapper entry points for corresponding +! C++ class {\tt ESMC\_Time} implementation +! +! See {\tt ../include/ESMC\_Time.h} for complete description +! +!------------------------------------------------------------------------------ +! !USES: + ! inherit from ESMF base class + use ESMF_BaseMod + + ! inherit from base time class + use ESMF_BaseTimeMod + + ! associated derived types + use ESMF_TimeIntervalMod + use ESMF_CalendarMod + use ESMF_ShrTimeMod, only : ESMF_Time +! added by Jhe + use ESMF_Stubs + + implicit none +! +!------------------------------------------------------------------------------ +! !PRIVATE TYPES: + private +!------------------------------------------------------------------------------ +! ! ESMF_Time +! +! ! F90 class type to match C++ Time class in size only; +! ! all dereferencing within class is performed by C++ implementation + +! move to ESMF_ShrTimeMod +! type ESMF_Time +! type(ESMF_BaseTime) :: basetime ! inherit base class +! ! time instant is expressed as year + basetime +! integer :: YR +! type(ESMF_Calendar), pointer :: calendar ! associated calendar +! end type +!------------------------------------------------------------------------------ +! !PUBLIC DATA: + +!------------------------------------------------------------------------------ +! !PUBLIC TYPES: + public ESMF_Time +!------------------------------------------------------------------------------ +! +! !PUBLIC MEMBER FUNCTIONS: + public ESMF_TimeGet + public ESMF_TimeSet + public ESMF_TimePrint + +! Required inherited and overridden ESMF_Base class methods + + public ESMF_TimeCopy + public ESMF_SetYearWidth + +! !PRIVATE MEMBER FUNCTIONS: + + private ESMF_TimeGetDayOfYear + private ESMF_TimeGetDayOfYearInteger + +! Inherited and overloaded from ESMF_BaseTime + + public operator(+) + public ESMF_TimeInc + + public operator(-) + private ESMF_TimeDec + private ESMF_TimeDiff + + public operator(.EQ.) + public ESMF_TimeEQ + + public operator(.NE.) + public ESMF_TimeNE + + public operator(.LT.) + public ESMF_TimeLT + + public operator(.GT.) + public ESMF_TimeGT + + public operator(.LE.) + public ESMF_TimeLE + + public operator(.GE.) + public ESMF_TimeGE + +!EOPI + +!------------------------------------------------------------------------------ +! The following line turns the CVS identifier string into a printable variable. + character(*), parameter, private :: version = & + '$Id$' + + integer :: yearWidth = 4 + +!============================================================================== +! +! INTERFACE BLOCKS +! +!============================================================================== +!BOP +! !INTERFACE: + interface ESMF_TimeGetDayOfYear + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeGetDayOfYearInteger + +! !DESCRIPTION: +! This interface overloads the {\tt ESMF\_GetDayOfYear} method +! for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(+) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeInc, ESMF_TimeInc2 + +! !DESCRIPTION: +! This interface overloads the + operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface assignment (=) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeCopy + +! !DESCRIPTION: +! This interface overloads the = operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(-) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeDec, ESMF_TimeDec2 + +! !DESCRIPTION: +! This interface overloads the - operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(-) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeDiff + +! !DESCRIPTION: +! This interface overloads the - operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.EQ.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeEQ + +! !DESCRIPTION: +! This interface overloads the .EQ. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.NE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeNE + +! !DESCRIPTION: +! This interface overloads the .NE. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.LT.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeLT + +! !DESCRIPTION: +! This interface overloads the .LT. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.GT.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeGT + +! !DESCRIPTION: +! This interface overloads the .GT. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.LE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeLE + +! !DESCRIPTION: +! This interface overloads the .LE. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ +!BOP +! !INTERFACE: + interface operator(.GE.) + +! !PRIVATE MEMBER FUNCTIONS: + module procedure ESMF_TimeGE + +! !DESCRIPTION: +! This interface overloads the .GE. operator for the {\tt ESMF\_Time} class +! +!EOP + end interface +! +!------------------------------------------------------------------------------ + +!============================================================================== + + contains + +!============================================================================== +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeGet - Get value in user-specified units + +! !INTERFACE: +! subroutine ESMF_TimeGet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, MS, & +! US, NS, d_, h_, m_, s_, ms_, us_, ns_, Sn, Sd, & +! dayOfYear, dayOfYear_r8, dayOfYear_intvl, & +! timeString, rc) + +recursive subroutine ESMF_TimeGet(time, YY, MM, DD, D, Dl, H, M, S, MS, & + Sn, Sd, & + dayOfYear, dayOfYear_r8, dayOfYear_intvl, & + timeString, rc) + +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + integer, intent(out), optional :: YY +! integer(ESMF_KIND_I8), intent(out), optional :: YRl + integer, intent(out), optional :: MM + integer, intent(out), optional :: DD + integer, intent(out), optional :: D + integer(ESMF_KIND_I8), intent(out), optional :: Dl + integer, intent(out), optional :: H + integer, intent(out), optional :: M + integer, intent(out), optional :: S +! integer(ESMF_KIND_I8), intent(out), optional :: Sl + integer, intent(out), optional :: MS +! integer, intent(out), optional :: US +! integer, intent(out), optional :: NS +! double precision, intent(out), optional :: d_ +! double precision, intent(out), optional :: h_ +! double precision, intent(out), optional :: m_ +! double precision, intent(out), optional :: s_ +! double precision, intent(out), optional :: ms_ +! double precision, intent(out), optional :: us_ +! double precision, intent(out), optional :: ns_ + integer, intent(out), optional :: Sn + integer, intent(out), optional :: Sd + integer, intent(out), optional :: dayOfYear + real(ESMF_KIND_R8), intent(out), optional :: dayOfYear_r8 + character (len=*), intent(out), optional :: timeString + type(ESMF_TimeInterval), intent(out), optional :: dayOfYear_intvl + integer, intent(out), optional :: rc + + +! !DESCRIPTION: +! Get the value of the {\tt ESMF\_Time} in units specified by the user +! via F90 optional arguments. +! +! Time manager represents and manipulates time internally with integers +! to maintain precision. Hence, user-specified floating point values are +! converted internally from integers. +! +! See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for +! complete description. +! +! The arguments are: +! \begin{description} +! \item[time] +! The object instance to query +! \item[{[YY]}] +! Integer year CCYR (>= 32-bit) +! \item[{[YRl]}] +! Integer year CCYR (large, >= 64-bit) +! \item[{[MM]}] +! Integer month 1-12 +! \item[{[DD]}] +! Integer day of the month 1-31 +! \item[{[D]}] +! Integer Julian days (>= 32-bit) +! \item[{[Dl]}] +! Integer Julian days (large, >= 64-bit) +! \item[{[H]}] +! Integer hours +! \item[{[M]}] +! Integer minutes +! \item[{[S]}] +! Integer seconds (>= 32-bit) +! \item[{[Sl]}] +! Integer seconds (large, >= 64-bit) +! \item[{[MS]}] +! Integer milliseconds +! \item[{[US]}] +! Integer microseconds +! \item[{[NS]}] +! Integer nanoseconds +! \item[{[d\_]}] +! Double precision days +! \item[{[h\_]}] +! Double precision hours +! \item[{[m\_]}] +! Double precision minutes +! \item[{[s\_]}] +! Double precision seconds +! \item[{[ms\_]}] +! Double precision milliseconds +! \item[{[us\_]}] +! Double precision microseconds +! \item[{[ns\_]}] +! Double precision nanoseconds +! \item[{[Sn]}] +! Integer fractional seconds - numerator +! \item[{[Sd]}] +! Integer fractional seconds - denominator +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG2.1, TMG2.5.1, TMG2.5.6 +!EOP + type(ESMF_TimeInterval) :: day_step + integer :: ierr + TYPE(ESMF_Time) :: begofyear + TYPE(ESMF_TimeInterval) :: difftobegofyear + INTEGER :: year, month, dayofmonth, hour, minute, second + INTEGER :: i + INTEGER(ESMF_KIND_I8) :: cnt + + ierr = ESMF_SUCCESS + + IF ( PRESENT( YY ) ) THEN + YY = time%YR + ENDIF + IF ( PRESENT( MM ) ) THEN + CALL timegetmonth( time, MM ) + ENDIF + IF ( PRESENT( DD ) ) THEN + CALL timegetdayofmonth( time, DD ) + ENDIF + + if (present(d) .or. present(dl)) then + cnt = 0 + do i = 0,time%yr-1 + cnt = cnt + ndaysinyear(i,time%calendar%type) + enddo + do i = time%yr,-1 + cnt = cnt - ndaysinyear(i,time%calendar%type) + enddo + call timegetmonth(time,month) + do i = 1,month-1 + cnt = cnt + ndaysinmonth(time%yr,i,time%calendar%type) + enddo + call timegetdayofmonth( time, dayofmonth) + cnt = cnt + dayofmonth + if (present(d)) then + d = cnt + endif + if (present(dl)) then + dl = cnt + endif + endif +! +!$$$ push HMS down into ESMF_BaseTime + IF ( PRESENT( H ) ) THEN + H = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR + ENDIF + IF ( PRESENT( M ) ) THEN + M = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE + ENDIF + IF ( PRESENT( S ) ) THEN + S = mod( time%basetime%S, SECONDS_PER_MINUTE ) + ENDIF + + IF ( PRESENT( S ) .AND. PRESENT( DD ) ) THEN + IF ( ( .NOT. PRESENT( H ) ) .AND. ( .NOT. PRESENT( M ) ) ) THEN + S = mod( time%basetime%S, SECONDS_PER_DAY ) + ENDIF + ENDIF + IF ( PRESENT( MS ) ) THEN + IF ( time%basetime%Sd /= 0 ) THEN + MS = NINT( ( time%basetime%Sn*1.0D0 / time%basetime%Sd*1.0D0 ) * 1000.0D0 ) + ELSE + MS = 0 + ENDIF + ENDIF + IF ( PRESENT( Sd ) .AND. PRESENT( Sn ) ) THEN + Sd = time%basetime%Sd + Sn = time%basetime%Sn + ENDIF + IF ( PRESENT( dayOfYear ) ) THEN + CALL ESMF_TimeGetDayOfYear( time, dayOfYear, rc=ierr ) + ENDIF + IF ( PRESENT( timeString ) ) THEN + ! This duplication for YMD is an optimization that avoids calling + ! timegetmonth() and timegetdayofmonth() when it is not needed. + year = time%YR + CALL timegetmonth( time, month ) + CALL timegetdayofmonth( time, dayofmonth ) +!$$$ push HMS down into ESMF_BaseTime + hour = mod( time%basetime%S, SECONDS_PER_DAY ) / SECONDS_PER_HOUR + minute = mod( time%basetime%S, SECONDS_PER_HOUR) / SECONDS_PER_MINUTE + second = mod( time%basetime%S, SECONDS_PER_MINUTE ) + CALL ESMFold_TimeGetString( year, month, dayofmonth, & + hour, minute, second, timeString ) + ENDIF + IF ( PRESENT( dayOfYear_intvl ) ) THEN + year = time%YR + CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & + calendar=time%calendar, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + dayOfYear_intvl = time - begofyear + ENDIF + IF ( PRESENT( dayOfYear_r8) ) THEN + year = time%YR + CALL ESMF_TimeSet( begofyear, yy=year, mm=1, dd=1, s=0, & + calendar=time%calendar, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + CALL ESMF_TimeIntervalSet( day_step, d=1, s=0, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + difftobegofyear = time - begofyear + day_step + CALL ESMF_TimeIntervalGet( difftobegofyear, d_r8=dayOfYear_r8, rc=ierr ) + IF ( ierr == ESMF_FAILURE)THEN + rc = ierr + RETURN + END IF + ENDIF + + IF ( PRESENT( rc ) ) THEN + rc = ierr + ENDIF + + end subroutine ESMF_TimeGet + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeSet - Initialize via user-specified unit set + +! !INTERFACE: +! subroutine ESMF_TimeSet(time, YY, YRl, MM, DD, D, Dl, H, M, S, Sl, & +! MS, US, NS, d_, h_, m_, s_, ms_, us_, ns_, & +! Sn, Sd, calendar, calkindflag, rc) + + subroutine ESMF_TimeSet(time, YY, MM, DD, D, Dl, H, M, S, & + MS, & + Sn, Sd, calendar, calkindflag, rc) + +! !ARGUMENTS: + type(ESMF_Time), intent(inout) :: time + integer, intent(in), optional :: YY +! integer(ESMF_KIND_I8), intent(in), optional :: YRl + integer, intent(in), optional :: MM + integer, intent(in), optional :: DD + integer, intent(in), optional :: D + integer(ESMF_KIND_I8), intent(in), optional :: Dl + integer, intent(in), optional :: H + integer, intent(in), optional :: M + integer, intent(in), optional :: S +! integer(ESMF_KIND_I8), intent(in), optional :: Sl + integer, intent(in), optional :: MS +! integer, intent(in), optional :: US +! integer, intent(in), optional :: NS +! double precision, intent(in), optional :: d_ +! double precision, intent(in), optional :: h_ +! double precision, intent(in), optional :: m_ +! double precision, intent(in), optional :: s_ +! double precision, intent(in), optional :: ms_ +! double precision, intent(in), optional :: us_ +! double precision, intent(in), optional :: ns_ + integer, intent(in), optional :: Sn + integer, intent(in), optional :: Sd + type(ESMF_Calendar), intent(in), target, optional :: calendar + type(ESMF_CalKind_Flag), intent(in), optional :: calkindflag + integer, intent(out), optional :: rc + + ! locals + INTEGER :: ierr + logical :: dset + +! !DESCRIPTION: +! Initializes a {\tt ESMF\_Time} with a set of user-specified units +! via F90 optional arguments. +! +! Time manager represents and manipulates time internally with integers +! to maintain precision. Hence, user-specified floating point values are +! converted internally to integers. +! +! See {\tt ../include/ESMC\_BaseTime.h and ../include/ESMC\_Time.h} for +! complete description. +! +! The arguments are: +! \begin{description} +! \item[time] +! The object instance to initialize +! \item[{[YY]}] +! Integer year CCYR (>= 32-bit) +! \item[{[YRl]}] +! Integer year CCYR (large, >= 64-bit) +! \item[{[MM]}] +! Integer month 1-12 +! \item[{[DD]}] +! Integer day of the month 1-31 +! \item[{[D]}] +! Integer Julian days (>= 32-bit) +! \item[{[Dl]}] +! Integer Julian days (large, >= 64-bit) +! \item[{[H]}] +! Integer hours +! \item[{[M]}] +! Integer minutes +! \item[{[S]}] +! Integer seconds (>= 32-bit) +! \item[{[Sl]}] +! Integer seconds (large, >= 64-bit) +! \item[{[MS]}] +! Integer milliseconds +! \item[{[US]}] +! Integer microseconds +! \item[{[NS]}] +! Integer nanoseconds +! \item[{[d\_]}] +! Double precision days +! \item[{[h\_]}] +! Double precision hours +! \item[{[m\_]}] +! Double precision minutes +! \item[{[s\_]}] +! Double precision seconds +! \item[{[ms\_]}] +! Double precision milliseconds +! \item[{[us\_]}] +! Double precision microseconds +! \item[{[ns\_]}] +! Double precision nanoseconds +! \item[{[Sn]}] +! Integer fractional seconds - numerator +! \item[{[Sd]}] +! Integer fractional seconds - denominator +! \item[{[cal]}] +! Associated {\tt Calendar} +! \item[{[tz]}] +! Associated timezone (hours offset from GMT, e.g. EST = -5) +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP +! PRINT *,'DEBUG: BEGIN ESMF_TimeSet()' +!$$$ push this down into ESMF_BaseTime constructor + + IF ( PRESENT( rc ) ) then + rc = ESMF_FAILURE + ENDIF + + time%YR = 0 + time%basetime%S = 0 + time%basetime%Sn = 0 + time%basetime%Sd = 0 + + IF ( PRESENT(calendar) )THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): using passed-in calendar' + IF ( .not. ESMF_CalendarInitialized( calendar ) )THEN + call wrf_error_fatal( "Error:: ESMF_CalendarCreate not "// & + "called on input Calendar") + END IF +! call flush(6) +! write(6,*) 'tcx1 ESMF_TimeSet point to calendar' +! call flush(6) + time%Calendar => calendar + ELSE +! PRINT *,'DEBUG: ESMF_TimeSet(): using default calendar' +! for the sake of WRF, check ESMF_IsInitialized, revised by Juanxiong He + IF ( .not. ESMF_IsInitialized() )THEN + call wrf_error_fatal( "Error:: ESMF_Initialize not called") + END IF +! IF ( .not. ESMF_CalendarInitialized( defaultCal ) )THEN +! call wrf_error_fatal( "Error:: ESMF_Initialize not called") +! END IF + if (present(calkindflag)) then +! write(6,*) 'tcx2 ESMF_TimeSet point to calendarkindflag',calkindflag%caltype +! call flush(6) + if (calkindflag%caltype == ESMF_CALKIND_GREGORIAN%caltype) then + time%Calendar => gregorianCal + elseif (calkindflag%caltype == ESMF_CALKIND_NOLEAP%caltype) then + time%Calendar => noleapCal + else + call wrf_error_fatal( "Error:: ESMF_TimeSet invalid calkindflag") + endif + else +! write(6,*) 'tcx3 ESMF_TimeSet point to defaultcal' +! call flush(6) + time%Calendar => defaultCal + endif + END IF +! write(6,*) 'tcxn ESMF_TimeSet ',ESMF_CALKIND_NOLEAP%caltype +! call flush(6) +! write(6,*) 'tcxg ESMF_TimeSet ',ESMF_CALKIND_GREGORIAN%caltype +! call flush(6) +! write(6,*) 'tcxt ESMF_TimeSet ',time%calendar%type%caltype +! call flush(6) + + dset = .false. + if (present(D)) then + if (present(Dl)) CALL wrf_error_fatal( 'ESMF_TimeSet: D and Dl not both valid') + time%basetime%s = SECONDS_PER_DAY * INT(D-1,ESMF_KIND_I8) + dset=.true. + elseif (present(Dl)) then + time%basetime%s = SECONDS_PER_DAY * Dl-1_ESMF_KIND_I8 + dset=.true. + endif + + IF ( PRESENT( YY ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): YY = ',YY + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') + time%YR = YY + ENDIF + IF ( PRESENT( MM ) ) THEN + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') +! PRINT *,'DEBUG: ESMF_TimeSet(): MM = ',MM + CALL timeaddmonths( time, MM, ierr ) + IF ( ierr == ESMF_FAILURE ) THEN + IF ( PRESENT( rc ) ) THEN + rc = ESMF_FAILURE + RETURN + ELSE + CALL wrf_error_fatal( 'ESMF_TimeSet: MM out of range' ) + ENDIF + ENDIF +! PRINT *,'DEBUG: ESMF_TimeSet(): back from timeaddmonths' + ENDIF + IF ( PRESENT( DD ) ) THEN + if (dset) CALL wrf_error_fatal( 'ESMF_TimeSet: D or DL and YY,MM,DD not both valid') +!$$$ no check for DD in range of days of month MM yet +!$$$ Must separate D and DD for correct interface! +! PRINT *,'DEBUG: ESMF_TimeSet(): DD = ',DD + time%basetime%S = time%basetime%S + & + ( SECONDS_PER_DAY * INT( (DD-1), ESMF_KIND_I8 ) ) + ENDIF +!$$$ push H,M,S,Sn,Sd,MS down into ESMF_BaseTime constructor + IF ( PRESENT( H ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): H = ',H + time%basetime%S = time%basetime%S + & + ( SECONDS_PER_HOUR * INT( H, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( M ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): M = ',M + time%basetime%S = time%basetime%S + & + ( SECONDS_PER_MINUTE * INT( M, ESMF_KIND_I8 ) ) + ENDIF + IF ( PRESENT( S ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): S = ',S + time%basetime%S = time%basetime%S + & + INT( S, ESMF_KIND_I8 ) + ENDIF + IF ( PRESENT( Sn ) .AND. ( .NOT. PRESENT( Sd ) ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeSet: Must specify Sd if Sn is specified") + ENDIF + IF ( PRESENT( Sd ) .AND. PRESENT( MS ) ) THEN + CALL wrf_error_fatal( & + "ESMF_TimeSet: Must not specify both Sd and MS") + ENDIF + time%basetime%Sn = 0 + time%basetime%Sd = 0 + IF ( PRESENT( MS ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): MS = ',MS + time%basetime%Sn = MS + time%basetime%Sd = 1000_ESMF_KIND_I8 + ELSE IF ( PRESENT( Sd ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): Sd = ',Sd + time%basetime%Sd = Sd + IF ( PRESENT( Sn ) ) THEN +! PRINT *,'DEBUG: ESMF_TimeSet(): Sn = ',Sn + time%basetime%Sn = Sn + ENDIF + ENDIF + +! PRINT *,'DEBUG: ESMF_TimeSet(): calling normalize_time()' +!$$$DEBUG +!IF ( time%basetime%Sd > 0 ) THEN +! PRINT *,'DEBUG ESMF_TimeSet() before normalize: S,Sn,Sd = ', & +! time%basetime%S, time%basetime%Sn, time%basetime%Sd +!ENDIF +!$$$END DEBUG + CALL normalize_time( time ) +!$$$DEBUG +!IF ( time%basetime%Sd > 0 ) THEN +! PRINT *,'DEBUG ESMF_TimeSet() after normalize: S,Sn,Sd = ', & +! time%basetime%S, time%basetime%Sn, time%basetime%Sd +!ENDIF +!$$$END DEBUG + +! PRINT *,'DEBUG: ESMF_TimeSet(): back from normalize_time()' + IF ( PRESENT( rc ) ) THEN + rc = ESMF_SUCCESS + ENDIF + + end subroutine ESMF_TimeSet + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMFold_TimeGetString - Get time instant value in string format + +! !INTERFACE: + subroutine ESMFold_TimeGetString( year, month, dayofmonth, & + hour, minute, second, TimeString ) + +! !ARGUMENTS: + integer, intent(in) :: year + integer, intent(in) :: month + integer, intent(in) :: dayofmonth + integer, intent(in) :: hour + integer, intent(in) :: minute + integer, intent(in) :: second + character*(*), intent(out) :: TimeString + character*(256) :: TimeFormatString +! !DESCRIPTION: +! Convert {\tt ESMF\_Time}'s value into ISO 8601 format YYYY-MM-DDThh:mm:ss +! +! The arguments are: +! \begin{description} +! \item[time] +! The object instance to convert +! \item[TimeString] +! The string to return +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMG2.4.7 +!EOP + +!PRINT *,'DEBUG: ESMF_TimePrint(): YR,S,Sn,Sd = ',time%YR,time%basetime%S,time%basetime%Sn,time%basetime%Sd +!PRINT *,'DEBUG: ESMF_TimePrint(): year = ',year +!PRINT *,'DEBUG: ESMF_TimePrint(): month, dayofmonth = ',month,dayofmonth +!PRINT *,'DEBUG: ESMF_TimePrint(): hour = ',hour +!PRINT *,'DEBUG: ESMF_TimePrint(): minute = ',minute +!PRINT *,'DEBUG: ESMF_TimePrint(): second = ',second + +!$$$here... add negative sign for YR<0 +!$$$here... add Sn, Sd ?? + write(TimeFormatString,FMT="(A,I4.4,A,I4.4,A)") & + "(I", yearWidth, ".", yearWidth, ",'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)" + write(TimeString,FMT=TimeFormatString) year,month,dayofmonth,hour,minute,second + + end subroutine ESMFold_TimeGetString + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeGetDayOfYearInteger - Get time instant's day of the year as an integer value +! +! !INTERFACE: + subroutine ESMF_TimeGetDayOfYearInteger(time, DayOfYear, rc) +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + integer, intent(out) :: DayOfYear + integer, intent(out), optional :: rc +! +! !DESCRIPTION: +! Get the day of the year the given {\tt ESMF\_Time} instant falls on +! (1-365). Returned as an integer value +! +! The arguments are: +! \begin{description} +! \item[time] +! The object instance to query +! \item[DayOfYear] +! The {\tt ESMF\_Time} instant's day of the year (1-365) +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +!EOP + ! requires that time be normalized +!$$$ bug when Sn>0? test +!$$$ add tests + DayOfYear = ( time%basetime%S / SECONDS_PER_DAY ) + 1 + IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS + end subroutine ESMF_TimeGetDayOfYearInteger + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeInc - Increment time instant with a time interval +! +! !INTERFACE: + function ESMF_TimeInc(time, timeinterval) +! +! !RETURN VALUE: + type(ESMF_Time) :: ESMF_TimeInc +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + type(ESMF_TimeInterval), intent(in) :: timeinterval +! !LOCAL: + INTEGER :: year,month,day,sec,nmon,nyr,mpyi4 +! +! !DESCRIPTION: +! Increment {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, +! return resulting {\tt ESMF\_Time} instant +! +! Maps overloaded (+) operator interface function to +! {\tt ESMF\_BaseTime} base class +! +! The arguments are: +! \begin{description} +! \item[time] +! The given {\tt ESMF\_Time} to increment +! \item[timeinterval] +! The {\tt ESMF\_TimeInterval} to add to the given {\tt ESMF\_Time} +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 +!EOP + + mpyi4 = MONTHS_PER_YEAR + + ! copy ESMF_Time specific properties (e.g. calendar, timezone) + + ESMF_TimeInc = time +! write(6,*) 'tcx timeinc1 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + CALL normalize_time( ESMF_TimeInc ) + +! write(6,*) 'tcx timeint ',timeinterval%yr,timeinterval%mm,timeinterval%basetime%s + + ! add years and months by manually forcing incremental years then adjusting the day of + ! the month at the end if it's greater than the number of days in the month + ! esmf seems to do exactly this based on testing + + nmon = timeinterval%mm + nyr = timeinterval%yr + if (abs(nmon) > 0 .or. abs(nyr) > 0) then + call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) +! write(6,*) 'tcx timeinc mon1 ',year,month,day,sec,nyr,nmon + year = year + nyr + month = month + nmon + do while (month > MONTHS_PER_YEAR) + month = month - mpyi4 + year = year + 1 + enddo + do while (month < 1) + month = month + mpyi4 + year = year - 1 + enddo +! write(6,*) 'tcx timeinc mon2 ',year,month,day,sec + day = min(day,ndaysinmonth(year,month,ESMF_TimeInc%calendar%type)) + call ESMF_TimeSet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec,calkindflag=time%calendar%type) + call ESMF_TimeGet(ESMF_TimeInc,yy=year,mm=month,dd=day,s=sec) +! write(6,*) 'tcx timeinc mon3 ',nmon,year,month,day,sec + endif + + ! finally add seconds + +! write(6,*) 'tcx timeinc sec ',ESMF_TimeInc%basetime%s,timeinterval%basetime%s + ESMF_TimeInc%basetime = ESMF_TimeInc%basetime + timeinterval%basetime + + ! and normalize + +! write(6,*) 'tcx timeinc2p ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + + CALL normalize_time( ESMF_TimeInc ) + +! write(6,*) 'tcx timeinc2 ',ESMF_TimeInc%yr,ESMF_TimeInc%basetime%s + + end function ESMF_TimeInc + +! this is added for certain compilers that don't deal with commutativity + + function ESMF_TimeInc2(timeinterval, time) + type(ESMF_Time) :: ESMF_TimeInc2 + type(ESMF_Time), intent(in) :: time + type(ESMF_TimeInterval), intent(in) :: timeinterval + ESMF_TimeInc2 = ESMF_TimeInc( time, timeinterval ) + end function ESMF_TimeInc2 + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeDec - Decrement time instant with a time interval +! +! !INTERFACE: + function ESMF_TimeDec(time, timeinterval) +! +! !RETURN VALUE: + type(ESMF_Time) :: ESMF_TimeDec +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + type(ESMF_TimeInterval), intent(in) :: timeinterval +! !LOCAL: + TYPE (ESMF_TimeInterval) :: neginterval + +! !DESCRIPTION: +! Decrement {\tt ESMF\_Time} instant with a {\tt ESMF\_TimeInterval}, +! return resulting {\tt ESMF\_Time} instant +! +! Maps overloaded (-) operator interface function to +! {\tt ESMF\_BaseTime} base class +! +! The arguments are: +! \begin{description} +! \item[time] +! The given {\tt ESMF\_Time} to decrement +! \item[timeinterval] +! The {\tt ESMF\_TimeInterval} to subtract from the given +! {\tt ESMF\_Time} +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 +!EOP + + ESMF_TimeDec = time + + neginterval = timeinterval +!$$$push this down into a unary negation operator on TimeInterval + neginterval%basetime%S = -neginterval%basetime%S + neginterval%basetime%Sn = -neginterval%basetime%Sn + neginterval%YR = -neginterval%YR + neginterval%MM = -neginterval%MM + ESMF_TimeDec = time + neginterval + + end function ESMF_TimeDec + +! +! this is added for certain compilers that don't deal with commutativity +! + function ESMF_TimeDec2(timeinterval, time) + type(ESMF_Time) :: ESMF_TimeDec2 + type(ESMF_Time), intent(in) :: time + type(ESMF_TimeInterval), intent(in) :: timeinterval + ESMF_TimeDec2 = ESMF_TimeDec( time, timeinterval ) + end function ESMF_TimeDec2 +! +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeDiff - Return the difference between two time instants +! +! !INTERFACE: + function ESMF_TimeDiff(time1, time2) +! +! !RETURN VALUE: + type(ESMF_TimeInterval) :: ESMF_TimeDiff +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! !LOCAL: + TYPE(ESMF_BaseTime) :: cmptime, zerotime + integer :: yr + integer :: y1,m1,d1,s1,y2,m2,d2,s2 + integer :: rc + +! !DESCRIPTION: +! Return the {\tt ESMF\_TimeInterval} difference between two +! {\tt ESMF\_Time} instants, time1 - time2 +! +! Maps overloaded (-) operator interface function to +! {\tt ESMF\_BaseTime} base class +! +! The arguments are: +! \begin{description} +! \item[time1] +! The first {\tt ESMF\_Time} instant +! \item[time2] +! The second {\tt ESMF\_Time} instant +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.4, TMG2.4.4, TMG2.4.5, TMG2.4.6, TMG5.1, TMG5.2, TMG7.2 +!EOP + + CALL ESMF_TimeIntervalSet( ESMF_TimeDiff, rc=rc ) + + ESMF_TimeDiff%StartTime = time2 + ESMF_TimeDiff%StartTime_set = .true. + +! write(6,*) 'tcx timediff1 ',time2%yr,time2%basetime%s,time2%calendar%type%caltype +! write(6,*) 'tcx timediff2 ',time1%yr,time1%basetime%s,time1%calendar%type%caltype + + call ESMF_TimeGet(time2,yy=y2,mm=m2,dd=d2,s=s2) + call ESMF_TimeGet(time1,yy=y1,mm=m1,dd=d1,s=s1) + + ! Can either be yr/month based diff if diff is only in year and month + ! or absolute seconds if diff in day/seconds as well + + if (d1 == d2 .and. s1 == s2) then +! write(6,*) 'tcx timedifft ym' + ESMF_TimeDiff%YR = y1 - y2 + ESMF_TimeDiff%MM = m1 - m2 + cmptime%S = 0 + cmptime%Sn = 0 + cmptime%Sd = 0 + ESMF_TimeDiff%basetime = cmptime + else +! write(6,*) 'tcx timedifft sec' + ESMF_TimeDiff%YR = 0 + ESMF_TimeDiff%MM = 0 + ESMF_TimeDiff%basetime = time1%basetime - time2%basetime + IF ( time1%YR > time2%YR ) THEN + DO yr = time2%YR, ( time1%YR - 1 ) +! write(6,*) 'tcx timediff3 ',yr,nsecondsinyear(yr,time2%calendar%type) + ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S + nsecondsinyear(yr,time2%calendar%type) + ENDDO + ELSE IF ( time2%YR > time1%YR ) THEN + DO yr = time1%YR, ( time2%YR - 1 ) +! write(6,*) 'tcx timediff4 ',yr,nsecondsinyear(yr,time2%calendar%type) + ESMF_TimeDiff%basetime%S = ESMF_TimeDiff%basetime%S - nsecondsinyear(yr,time2%calendar%type) + ENDDO + ENDIF + endif + +! write(6,*) 'tcx timediff5 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s + + CALL normalize_timeint( ESMF_TimeDiff ) + +! write(6,*) 'tcx timediff6 ',ESMF_TimeDiff%YR, ESMF_TimeDiff%MM, ESMF_TimeDiff%basetime%s + + end function ESMF_TimeDiff + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeEQ - Compare two times for equality +! +! !INTERFACE: + function ESMF_TimeEQ(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeEQ +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! +! !DESCRIPTION: +! Return true if both given {\tt ESMF\_Time} instants are equal, false +! otherwise. Maps overloaded (==) operator interface function to +! {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeEQ = (res .EQ. 0) + + end function ESMF_TimeEQ + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeNE - Compare two times for non-equality +! +! !INTERFACE: + function ESMF_TimeNE(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeNE +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 + +! !DESCRIPTION: +! Return true if both given {\tt ESMF\_Time} instants are not equal, false +! otherwise. Maps overloaded (/=) operator interface function to +! {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeNE = (res .NE. 0) + + end function ESMF_TimeNE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeLT - Time instant 1 less than time instant 2 ? +! +! !INTERFACE: + function ESMF_TimeLT(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeLT +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! +! !DESCRIPTION: +! Return true if first {\tt ESMF\_Time} instant is less than second +! {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (<) +! operator interface function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeLT = (res .LT. 0) + + end function ESMF_TimeLT + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeGT - Time instant 1 greater than time instant 2 ? +! +! !INTERFACE: + function ESMF_TimeGT(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeGT +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! +! !DESCRIPTION: +! Return true if first {\tt ESMF\_Time} instant is greater than second +! {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (>) operator +! interface function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeGT = (res .GT. 0) + + end function ESMF_TimeGT + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeLE - Time instant 1 less than or equal to time instant 2 ? +! +! !INTERFACE: + function ESMF_TimeLE(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeLE +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! +! !DESCRIPTION: +! Return true if first {\tt ESMF\_Time} instant is less than or equal to +! second {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (<=) +! operator interface function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeLE = (res .LE. 0) + + end function ESMF_TimeLE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeGE - Time instant 1 greater than or equal to time instant 2 ? +! +! !INTERFACE: + function ESMF_TimeGE(time1, time2) +! +! !RETURN VALUE: + logical :: ESMF_TimeGE +! +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time1 + type(ESMF_Time), intent(in) :: time2 +! +! !DESCRIPTION: +! Return true if first {\tt ESMF\_Time} instant is greater than or equal to +! second {\tt ESMF\_Time} instant, false otherwise. Maps overloaded (>=) +! operator interface function to {\tt ESMF\_BaseTime} base class. +! +! The arguments are: +! \begin{description} +! \item[time1] +! First time instant to compare +! \item[time2] +! Second time instant to compare +! \end{description} +! +! !REQUIREMENTS: +! TMG1.5.3, TMG2.4.3, TMG7.2 +!EOP + + integer :: res + + call timecmp(time1,time2,res) + ESMF_TimeGE = (res .GE. 0) + + end function ESMF_TimeGE + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimeCopy - Copy a time-instance + +! !INTERFACE: + subroutine ESMF_TimeCopy(timeout, timein) + +! !ARGUMENTS: + type(ESMF_Time), intent(out) :: timeout + type(ESMF_Time), intent(in) :: timein + +! !DESCRIPTION: +! Copy a time-instance to a new instance. +! +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + + timeout%basetime = timein%basetime + timeout%YR = timein%YR + timeout%Calendar => timein%Calendar +!tcx timeout%Calendar = timein%Calendar +! write(6,*) 'tcxa ESMF_TimeCopy' +! call flush(6) +! write(6,*) 'tcxb ESMF_TimeCopy',timein%calendar%type%caltype +! call flush(6) + timeout%Calendar = ESMF_CalendarCreate(calkindflag=timein%calendar%type) + + end subroutine ESMF_TimeCopy + + +!------------------------------------------------------------------------------ +!BOP +! !IROUTINE: ESMF_TimePrint - Print out a time instant's properties + + +! !INTERFACE: + subroutine ESMF_TimePrint(time, options, rc) + +! !ARGUMENTS: + type(ESMF_Time), intent(in) :: time + character (len=*), intent(in), optional :: options + integer, intent(out), optional :: rc + character (len=256) :: timestr + +! !DESCRIPTION: +! To support testing/debugging, print out a {\tt ESMF\_Time}'s +! properties. +! +! The arguments are: +! \begin{description} +! \item[time] +! {\tt ESMF\_Time} instant to print out +! \item[{[options]}] +! Print options +! \item[{[rc]}] +! Return code; equals {\tt ESMF\_SUCCESS} if there are no errors. +! \end{description} +! +! !REQUIREMENTS: +! TMGn.n.n +!EOP + + ! Quick hack to mimic ESMF 2.0.1 + ! Really should check value of options... + IF ( PRESENT( options ) ) THEN + CALL ESMF_TimeGet( time, timeString=timestr, rc=rc ) + timestr(11:11) = 'T' ! ISO 8601 compatibility hack for debugging + print *,' Time -----------------------------------' + print *,' ',TRIM(timestr) + print *,' end Time -------------------------------' + print * + ELSE + call print_a_time (time) + ENDIF + + end subroutine ESMF_TimePrint + +!============================================================================== + +SUBROUTINE print_a_time( time ) + IMPLICIT NONE + type(ESMF_Time) time + character*128 :: s + integer rc + CALL ESMF_TimeGet( time, timeString=s, rc=rc ) + print *,'Print a time|',TRIM(s),'|' + write(0,*)'Print a time|',TRIM(s),'|' + return +END SUBROUTINE print_a_time + +!============================================================================== + +SUBROUTINE timecmp(time1, time2, retval ) + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval +! +! !ARGUMENTS: + TYPE(ESMF_Time), INTENT(IN) :: time1 + TYPE(ESMF_Time), INTENT(IN) :: time2 + IF ( time1%YR .GT. time2%YR ) THEN ; retval = 1 ; RETURN ; ENDIF + IF ( time1%YR .LT. time2%YR ) THEN ; retval = -1 ; RETURN ; ENDIF + CALL seccmp( time1%basetime%S, time1%basetime%Sn, time1%basetime%Sd, & + time2%basetime%S, time2%basetime%Sn, time2%basetime%Sd, & + retval ) +END SUBROUTINE timecmp + +!============================================================================== + +SUBROUTINE normalize_time( time ) + ! A normalized time has time%basetime >= 0, time%basetime less than the current + ! year expressed as a timeInterval, and time%YR can take any value + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(INOUT) :: time +! INTEGER(ESMF_KIND_I8) :: nsecondsinyear + ! locals + TYPE(ESMF_BaseTime) :: cmptime, zerotime + INTEGER :: rc + LOGICAL :: done + + ! first, normalize basetime + ! this will force abs(Sn) < Sd and ensure that signs of S and Sn match + + CALL normalize_basetime( time%basetime ) + + ! next, underflow negative seconds into YEARS + ! time%basetime must end up non-negative + + zerotime%S = 0 + zerotime%Sn = 0 + zerotime%Sd = 0 + DO WHILE ( time%basetime < zerotime ) + time%YR = time%YR - 1 + cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) + cmptime%Sn = 0 + cmptime%Sd = 0 + time%basetime = time%basetime + cmptime + ENDDO + + ! next, overflow seconds into YEARS + done = .FALSE. + DO WHILE ( .NOT. done ) + cmptime%S = nsecondsinyear( time%YR, time%calendar%type ) + cmptime%Sn = 0 + cmptime%Sd = 0 + IF ( time%basetime >= cmptime ) THEN + time%basetime = time%basetime - cmptime + time%YR = time%YR + 1 + ELSE + done = .TRUE. + ENDIF + ENDDO + +END SUBROUTINE normalize_time + +!============================================================================== + +SUBROUTINE timegetmonth( time, MM ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(IN) :: time + INTEGER, INTENT(OUT) :: MM + ! locals + + mm = nmonthinyearsec(time%yr,time%basetime,time%calendar%type) + +END SUBROUTINE timegetmonth + +!============================================================================== +SUBROUTINE timegetdayofmonth( time, DD ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(IN) :: time + INTEGER, INTENT(OUT) :: DD + ! locals + + dd = ndayinyearsec(time%yr, time%basetime, time%calendar%type) + +END SUBROUTINE timegetdayofmonth + +!============================================================================== + +! Increment Time by number of seconds between start of year and start +! of month MM. +! 1 <= MM <= 12 +! Time is NOT normalized. +SUBROUTINE timeaddmonths( time, MM, ierr ) + IMPLICIT NONE + TYPE(ESMF_Time), INTENT(INOUT) :: time + INTEGER, INTENT(IN) :: MM + INTEGER, INTENT(OUT) :: ierr + ! locals + INTEGER(ESMF_KIND_I8) :: isec + + ierr = ESMF_SUCCESS + IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN + CALL wrf_message( 'ERROR timeaddmonths(): MM out of range' ) + ierr = ESMF_FAILURE + return + ENDIF + + isec = nsecondsinyearmonth(time%yr,MM,time%calendar%type) + time%basetime%s = time%basetime%s + isec + +END SUBROUTINE timeaddmonths + +!============================================================================== + +! Increment Time by number of seconds between start of year and start +! of month MM. +! 1 <= MM <= 12 +! Time is NOT normalized. +SUBROUTINE ESMF_setYearWidth( yearWidthIn ) + + integer, intent(in) :: yearWidthIn + + yearWidth = yearWidthIn + +END SUBROUTINE ESMF_setYearWidth + +!============================================================================== +!============================================================================== +end module ESMF_TimeMod diff --git a/share/esmf_wrf_timemgr/Makefile b/share/esmf_wrf_timemgr/Makefile new file mode 100644 index 000000000000..192a52c2b6d4 --- /dev/null +++ b/share/esmf_wrf_timemgr/Makefile @@ -0,0 +1,60 @@ +.SUFFIXES: .F90 .o + +OBJS = ESMF_AlarmClockMod.o \ + ESMF_AlarmMod.o \ + ESMF_BaseMod.o \ + ESMF_BaseTimeMod.o \ + ESMF_CalendarMod.o \ + ESMF_ClockMod.o \ + ESMF.o \ + ESMF_FractionMod.o \ + ESMF_ShrTimeMod.o \ + ESMF_Stubs.o \ + ESMF_TimeIntervalMod.o \ + ESMF_TimeMod.o \ + MeatMod.o \ + wrf_error_fatal.o \ + wrf_message.o + +all: $(OBJS) + ar -ru libesmf_time.a *.o + +ESMF_AlarmClockMod.o: ESMF_AlarmMod.o ESMF_ClockMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o + +ESMF_AlarmMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o + +ESMF_BaseMod.o: + +ESMF_BaseTimeMod.o: ESMF_BaseMod.o + +ESMF_CalendarMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o + +ESMF_ClockMod.o: ESMF_BaseMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_AlarmMod.o ESMF_TimeMod.o + +ESMF.o: ESMF_AlarmMod.o ESMF_BaseMod.o ESMF_BaseTimeMod.o \ + ESMF_CalendarMod.o ESMF_ClockMod.o ESMF_FractionMod.o \ + ESMF_TimeIntervalMod.o ESMF_TimeMod.o ESMF_ShrTimeMod.o \ + ESMF_AlarmClockMod.o ESMF_Stubs.o MeatMod.o + +ESMF_FractionMod.o: + +ESMF_ShrTimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_CalendarMod.o + +ESMF_Stubs.o: ESMF_BaseMod.o ESMF_CalendarMod.o + +ESMF_TimeIntervalMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_FractionMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o + +ESMF_TimeMod.o: ESMF_BaseMod.o ESMF_BaseTimeMod.o ESMF_TimeIntervalMod.o ESMF_CalendarMod.o ESMF_ShrTimeMod.o ESMF_Stubs.o + +MeatMod.o: ESMF_BaseMod.o + +wrf_error_fatal.o: + +wrf_message.o: + +clean: + rm -rf *.o *.mod *.a + +.F90.o: + $(RM) $@ $*.mod + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. diff --git a/share/esmf_wrf_timemgr/MeatMod.F90 b/share/esmf_wrf_timemgr/MeatMod.F90 new file mode 100644 index 000000000000..c9ab2ec145ee --- /dev/null +++ b/share/esmf_wrf_timemgr/MeatMod.F90 @@ -0,0 +1,66 @@ + +module MeatMod + +#include + + use ESMF_BaseMod + + implicit none + + private + + public fraction_to_stringi8 + public fraction_to_string + +!============================================================================== +contains +!============================================================================== + +!============================================================================== + +!============================================================================== +! Convert fraction to string with leading sign. +! If fraction simplifies to a whole number or if +! denominator is zero, return empty string. +! INTEGER*8 interface. +SUBROUTINE fraction_to_stringi8( numerator, denominator, frac_str ) + IMPLICIT NONE + INTEGER(ESMF_KIND_I8), INTENT(IN) :: numerator + INTEGER(ESMF_KIND_I8), INTENT(IN) :: denominator + CHARACTER (LEN=*), INTENT(OUT) :: frac_str + IF ( denominator > 0 ) THEN + IF ( mod( numerator, denominator ) /= 0 ) THEN + IF ( numerator > 0 ) THEN + WRITE(frac_str,FMT="('+',I2.2,'/',I2.2)") abs(numerator), denominator + ELSE ! numerator < 0 + WRITE(frac_str,FMT="('-',I2.2,'/',I2.2)") abs(numerator), denominator + ENDIF + ELSE ! includes numerator == 0 case + frac_str = '' + ENDIF + ELSE ! no-fraction case + frac_str = '' + ENDIF +END SUBROUTINE fraction_to_stringi8 + +!============================================================================== + +! Convert fraction to string with leading sign. +! If fraction simplifies to a whole number or if +! denominator is zero, return empty string. +! INTEGER interface. +SUBROUTINE fraction_to_string( numerator, denominator, frac_str ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: numerator + INTEGER, INTENT(IN) :: denominator + CHARACTER (LEN=*), INTENT(OUT) :: frac_str + ! locals + INTEGER(ESMF_KIND_I8) :: numerator_i8, denominator_i8 + numerator_i8 = INT( numerator, ESMF_KIND_I8 ) + denominator_i8 = INT( denominator, ESMF_KIND_I8 ) + CALL fraction_to_stringi8( numerator_i8, denominator_i8, frac_str ) +END SUBROUTINE fraction_to_string + +!============================================================================== + +end module MeatMod diff --git a/share/esmf_wrf_timemgr/README b/share/esmf_wrf_timemgr/README new file mode 100644 index 000000000000..e8c73ef5fe41 --- /dev/null +++ b/share/esmf_wrf_timemgr/README @@ -0,0 +1,19 @@ + +Quick README +Tony Craig, Feb, 2012 + +This is a partial substitute for the ESMF Time Manager. As of Feb, 2012, +what exists is consist (in interfaces and datatypes) with ESMF 5.2.0rp1. +The datatypes in this version are not interchangable with ESMF nor will the +answers be exactly identical. + +This version supports the NOLEAP and GREGORIAN calendar. It also supports +use of the D and Dl interfaces in ESMF_TimeSet and ESMF_TimeGet. The julian +day reference is that day 1 is year 0, month 1, day 1 (0000-01-01 or Jan 1, 0000). +It also supports positive or negative years. + +Several aspects of the ESMF interfaces are not supported. + +There is a unit tester that tests ESMF_Time and ESMF_TimeInterval actions +for both gregorian and noleap calendar. + diff --git a/share/esmf_wrf_timemgr/unittests/Makefile b/share/esmf_wrf_timemgr/unittests/Makefile new file mode 100644 index 000000000000..24482dda92f6 --- /dev/null +++ b/share/esmf_wrf_timemgr/unittests/Makefile @@ -0,0 +1,63 @@ + +cpp_dirs := . .. +cpp_path := $(foreach dir,$(cpp_dirs),-I$(dir)) # format for command line +# Expand any tildes in directory names. Change spaces to colons. +VPATH := $(foreach dir,$(cpp_dirs),$(wildcard $(dir))) +VPATH := $(subst $(space),:,$(VPATH)) + +#VPATH := .:.. + + +.SUFFIXES: .F90 .o .F .f90 + +AR := ar +FC := xlf95 +FFLAGS := -g -qfullpath -qmaxmem=-1 -O2 -qstrict -qsigtrap=xl__trcedump -Q -qinitauto=7FF7FFFF -qflttrap=ov:zero:inv:en -qspillsize=4000 -qarch=auto -qtune=auto -qsuffix=f=f90:cpp=F90 -I. -I.. -WF,-DHIDE_MPI +LDFLAGS := + +OBJS := ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ + MeatMod.o ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o \ + ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF.o ESMF_ShrTimeMod.o \ + ESMF_AlarmClockMod.o wrf_stuff.o + +test: libesmf_time.a test.o + $(FC) $(LDFLAGS) -o test test.o -L. -lesmf_time + +lib: libesmf_time.a + +debug: $(OBJS) + echo "VPATH : $VPATH" + echo "OBJS : $OBJ" + echo "FFLAGS: $FFLAGS" + +libesmf_time.a : $(OBJS) + \rm -f libesmf_time.a + $(AR) $(ARFLAGS) libesmf_time.a $(OBJS) + +.F90.o : + $(FC) -c $(FFLAGS) $< + +clean: + /bin/rm -f *.o libesmf_time.a *.mod test + +# DEPENDENCIES : only dependencies after this line + +#$$$ update dependencies! + +ESMF_BaseMod.o : ESMF_BaseMod.F90 wrf_stuff.o +ESMF_FractionMod.o: ESMF_FractionMod.F90 +MeatMod.o : MeatMod.F90 ESMF_BaseMod.o +ESMF_BaseTimeMod.o : ESMF_BaseTimeMod.F90 ESMF_BaseMod.o +ESMF_CalendarMod.o : ESMF_CalendarMod.F90 ESMF_BaseMod.o ESMF_BaseTimeMod.o +ESMF_Stubs.o : ESMF_Stubs.F90 ESMF_CalendarMod.o ESMF_BaseMod.o +ESMF_ShrTimeMod.o : ESMF_ShrTimeMod.F90 ESMF_CalendarMod.o ESMF_BaseTimeMod.o ESMF_BaseMod.o +ESMF_TimeIntervalMod.o : ESMF_TimeIntervalMod.F90 ESMF_FractionMod.o +ESMF_TimeMod.o : ESMF_TimeMod.F90 ESMF_ShrTimeMod.o ESMF_Stubs.o ESMF_TimeIntervalMod.o +ESMF_AlarmMod.o : ESMF_AlarmMod.F90 ESMF_BaseTimeMod.o ESMF_TimeMod.o ESMF_TimeIntervalMod.o +ESMF_ClockMod.o : ESMF_ClockMod.F90 ESMF_BaseTimeMod.o ESMF_TimeMod.o ESMF_TimeIntervalMod.o ESMF_AlarmMod.o +ESMF_AlarmClockMod.o : ESMF_AlarmClockMod.F90 ESMF_AlarmMod.o ESMF_ClockMod.o ESMF_TimeIntervalMod.o ESMF_TimeMod.o +ESMF.o : ESMF.F90 ESMF_AlarmMod.o ESMF_BaseTimeMod.o ESMF_ClockMod.o ESMF_TimeMod.o \ + ESMF_BaseMod.o ESMF_CalendarMod.o ESMF_FractionMod.o ESMF_ShrTimeMod.o \ + ESMF_TimeIntervalMod.o ESMF_Stubs.o ESMF_AlarmClockMod.o +test.o : test.F90 ESMF.o + diff --git a/share/esmf_wrf_timemgr/unittests/go.csh b/share/esmf_wrf_timemgr/unittests/go.csh new file mode 100755 index 000000000000..77641ffb355e --- /dev/null +++ b/share/esmf_wrf_timemgr/unittests/go.csh @@ -0,0 +1,14 @@ +#!/bin/csh + +rm -f ./test +gmake +rm -f ./test.out +./test >& test.out + +tail -5 test.out +set nd = `diff test.out.base test.out | wc -l` + +echo "diffs vs baseline = $nd" + + + diff --git a/share/esmf_wrf_timemgr/unittests/test.F90 b/share/esmf_wrf_timemgr/unittests/test.F90 new file mode 100644 index 000000000000..e94ded972c59 --- /dev/null +++ b/share/esmf_wrf_timemgr/unittests/test.F90 @@ -0,0 +1,312 @@ + + program test + + use esmf + + implicit none + + type(ESMF_Time) :: time1,time2,time3,time4,time5,time6,time7,time8 + type(ESMF_TimeInterval) :: timeint1,timeint2,timeint3,timeint4,timeint5 + type(ESMF_Calkind_Flag) :: calkindflag + + integer :: year,month,day,hour,min,sec,jday + integer :: year1,month1,day1,hour1,min1,sec1,jday1 + integer :: year2,month2,day2,hour2,min2,sec2,jday2 + integer :: iyear,imonth,iday,ihour,imin,isec + integer :: dyear,dmonth,dday,dhour,dmin,dsec + integer :: icyear,icmonth,icday,ichour,icmin,icsec + integer :: ical,i1,i2,delta + integer :: errcnt, totcnt + logical :: errfound + character(len=8) :: dstr,calstr + character(len=32) :: estr1,estr2 + + INTEGER, PARAMETER :: mday(12) & + = (/31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER, PARAMETER :: mdayleap(12) & + = (/31,29,31,30,31,30,31,31,30,31,30,31/) + + character(len=*),parameter :: F01 = "(2x,a,1x,a6,i6,'-',i2.2,'-',i2.2,1x,i2.2,':',i2.2,':',i2.2,1x,a8,i12,a8,i6)" + character(len=*),parameter :: F02 = "(a,1x,a6,2x,i6,'-',i2.2,'-',i2.2,1x,i2.2,':',i2.2,':',i2.2,1x,a8,i12)" + character(len=*),parameter :: F03 = "(a,1x,i6,'-',i2.2,'-',i2.2,1x,a8,a8,i12)" + + call ESMF_Initialize() + + totcnt = 0 + errcnt = 0 + + do icyear = 1,8 + do icmonth = 1,12 + do icday = 1,4 + do ichour = 2,2 + do icmin = 30,30 + do icsec = 10,10 + do ical = 1,2 + + write(6,*) ' ' + write(estr1,'(i2.2,i2.2,i2.2,i2.2,i2.2,i2.2,i2.2)') icyear,icmonth,icday,ichour,icmin,icsec,ical + + if (icyear == 1) iyear = 0 + if (icyear == 2) iyear = 1 + if (icyear == 3) iyear = 1900 + if (icyear == 4) iyear = 1995 + if (icyear == 5) iyear = 1996 + if (icyear == 6) iyear = 2000 + if (icyear == 7) iyear = 9900 + if (icyear == 8) iyear = 9999 + + imonth = icmonth + + if (icday == 1) iday = 1 + if (icday == 2) iday = 20 + if (icday == 3) iday = mday(imonth)-1 + if (icday == 4) iday = mday(imonth) + + ihour = ichour + + imin = icmin + + isec = icsec + + if (ical == 1) then + calstr = 'noleap' + calkindflag = ESMF_CALKIND_NOLEAP + endif + if (ical == 2) then + calstr = 'gregor' + calkindflag = ESMF_CALKIND_GREGORIAN + endif + + write(6,F02) trim(estr1),'jd0 ',iyear,imonth,iday,ihour,imin,isec,trim(calstr) + + call ESMF_TimeSet(time1,yy=iyear,mm=imonth,dd=iday,h=ihour,m=imin,s=isec,calkindflag=calkindflag) + + call ESMF_TimeGet(time1,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time1,d=jday) + write(6,F02) trim(estr1),'jd1 ',year,month,day,hour,min,sec,trim(calstr),jday + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeSet(time2,d=jday,calkindflag=calkindflag) + call ESMF_TimeGet(time2,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time2,d=jday) + write(6,F02) trim(estr1),'jd2 ',year,month,day,hour,min,sec,trim(calstr),jday + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + if (year /= iyear .or. month /= imonth .or. day /= iday) then + call wrf_error_fatal('ERROR: jday conversion') + endif + + do i1 = 1,7 + do i2 = 1,4 + write(6,*) ' ' + write(estr2,'(a,i2.2,i2.2)') trim(estr1),i1,i2 + + if (i2 == 1) delta = 1 + if (i2 == 2) delta = -1 + if (i2 == 3) delta = 150 + if (i2 == 4) delta = -150 + + dyear = 0 + dmonth = 0 + dday = 0 + dhour =0 + dmin = 0 + dsec = 0 + + if (i1 == 1) then + dstr = 'year' + dyear = delta + endif + if (i1 == 2) then + dstr = 'month' + dmonth = delta + endif + if (i1 == 3) then + dstr = 'day' + dday = delta + endif + if (i1 == 4) then + dstr = 'hour' + dhour = delta + endif + if (i1 == 5) then + dstr = 'min' + dmin = delta + endif + if (i1 == 6) then + dstr = 'sec' + dsec = delta + endif + if (i1 == 7) then + dstr = 'all' + dyear = delta + dmonth = delta + dday = delta + dhour = delta + dmin = delta + dsec = delta + endif + + call ESMF_TimeIntervalSet(timeint1,yy= dyear,mm= dmonth,d= dday,h= dhour,m= dmin,s= dsec) + call ESMF_TimeIntervalSet(timeint2,yy=2*dyear,mm=2*dmonth,d=2*dday,h=2*dhour,m=2*dmin,s=2*dsec) + call ESMF_TimeIntervalSet(timeint3,yy=-dyear,mm=-dmonth,d=-dday,h=-dhour,m=-dmin,s=-dsec) + + !time1 = ! zero + time2 = time1 + timeint1 ! + delta + timeint4 = time2 - time1 ! this should be same as timeint1 but only for time2-time1 + time3 = time2 - timeint4 ! zero + time4 = time3 + timeint2 ! + 2*delta + time5 = time4 - timeint1 ! + delta + time6 = time5 + timeint3 ! zero + time7 = time6 + timeint3 ! - delta + time8 = time7 - timeint3 ! zero + + call ESMF_TimeGet(time1,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time1,d=jday) + write(6,F01) trim(estr2),'ti1 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time2,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time2,d=jday) + write(6,F01) trim(estr2),'ti2 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time3,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time3,d=jday) + write(6,F01) trim(estr2),'ti3 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time4,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time4,d=jday) + write(6,F01) trim(estr2),'ti4 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time5,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time5,d=jday) + write(6,F01) trim(estr2),'ti5 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time6,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time6,d=jday) + write(6,F01) trim(estr2),'ti6 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time7,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time7,d=jday) + write(6,F01) trim(estr2),'ti7 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time8,yy=year,mm=month,dd=day,h=hour,m=min,s=sec) + call ESMF_TimeGet(time8,d=jday) + write(6,F01) trim(estr2),'ti8 ',year,month,day,hour,min,sec,trim(calstr),jday,trim(dstr),delta + call checkdate(year,month,day,hour,min,sec,trim(calstr)) + + call ESMF_TimeGet(time1,yy=year1,mm=month1,dd=day1,h=hour1,m=min1,s=sec1) + call ESMF_TimeGet(time1,d=jday1) + call ESMF_TimeGet(time8,yy=year2,mm=month2,dd=day2,h=hour2,m=min2,s=sec2) + call ESMF_TimeGet(time8,d=jday2) + + totcnt = totcnt + 1 + errfound = .false. + + if (time1 /= time3) then + if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then + write(6,F03) 'ERROR: timediff non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta + if (.not. errfound) errcnt = errcnt + 1 + errfound = .true. + else + call wrf_error_fatal('ERROR: timeinc time') + endif + endif + + if (time3 /= time6) then + if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then + write(6,F03) 'ERROR: time2x non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta + if (.not. errfound) errcnt = errcnt + 1 + errfound = .true. + else + call wrf_error_fatal('ERROR: timeinc time') + endif + endif + + if (time6 /= time8) then + if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then + write(6,F03) 'ERROR: timeneg non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta + if (.not. errfound) errcnt = errcnt + 1 + errfound = .true. + else + call wrf_error_fatal('ERROR: timeinc time') + endif + endif + + if (time2 /= time5) then + if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then + write(6,F03) 'ERROR: timecomp non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta + if (.not. errfound) errcnt = errcnt + 1 + errfound = .true. + else + call wrf_error_fatal('ERROR: timeinc time') + endif + endif + + if (year1 /= year2 .or. month1 /= month2 .or. day1 /= day2 .or. & + hour1 /= hour2 .or. min1 /= min2 .or. sec1 /= sec2 .or. jday1 /= jday2) then + if (trim(dstr) == 'month' .or. trim(dstr) == 'all') then + write(6,F03) 'ERROR: ymdhms non fatal',year1,month1,day1,trim(calstr),trim(dstr),delta + if (.not. errfound) errcnt = errcnt + 1 + errfound = .true. + else + call wrf_error_fatal('ERROR: timeinc ymdhms') + endif + endif + + enddo + enddo + + enddo + enddo + enddo + enddo + enddo + enddo + enddo + + write(6,*) ' ' + write(6,*) 'tests run = ',totcnt,' error tests = ',errcnt + write(6,*) 'esmf_wrf_timemgr test program completed successfully ' + write(6,*) ' ' + + end program test + + + subroutine checkdate(year,month,day,hour,min,sec,calstr) + + implicit none + integer, intent(in) :: year,month,day,hour,min,sec + character(len=*),intent(in) :: calstr + INTEGER, PARAMETER :: mday(12) & + = (/31,28,31,30,31,30,31,31,30,31,30,31/) + INTEGER, PARAMETER :: mdayleap(12) & + = (/31,29,31,30,31,30,31,31,30,31,30,31/) + logical :: error + + error = .false. + + if (month < 1 .or. month > 12) error = .true. + if (trim(calstr) == 'noleap') then + if (day < 1 .or. day > mday(month)) error = .true. + elseif (trim(calstr) == 'gregor') then + if (day < 1 .or. day > mdayleap(month)) error = .true. + else + error = .true. + endif + if (hour < 0 .or. hour > 23) error = .true. + if (min < 0 .or. min > 59) error = .true. + if (sec < 0 .or. sec > 59) error = .true. + + if (error) then + write(6,*) 'ERROR checkdate ',year,month,day,hour,min,sec,trim(calstr) + call wrf_error_fatal('ERROR: checkdate') + endif + + end subroutine checkdate diff --git a/share/esmf_wrf_timemgr/unittests/wrf_stuff.F90 b/share/esmf_wrf_timemgr/unittests/wrf_stuff.F90 new file mode 100644 index 000000000000..c723ae20e9a9 --- /dev/null +++ b/share/esmf_wrf_timemgr/unittests/wrf_stuff.F90 @@ -0,0 +1,17 @@ + +SUBROUTINE wrf_message( str ) + IMPLICIT NONE + CHARACTER*(*) str + write(6,*) 'wrf_message ',trim(str) +END SUBROUTINE wrf_message + + +SUBROUTINE wrf_error_fatal( str ) + IMPLICIT NONE + CHARACTER*(*) str + write(6,*) 'wrf_error_fatal ',trim(str) + stop +END SUBROUTINE wrf_error_fatal + + + diff --git a/share/esmf_wrf_timemgr/wrf_error_fatal.F90 b/share/esmf_wrf_timemgr/wrf_error_fatal.F90 new file mode 100644 index 000000000000..e7b0ee627271 --- /dev/null +++ b/share/esmf_wrf_timemgr/wrf_error_fatal.F90 @@ -0,0 +1,9 @@ + +subroutine wrf_error_fatal(msg) + use shr_sys_mod, only: shr_sys_abort + implicit none + character(len=*), intent(in) :: msg + write(6,*) 'wrf_error_fatal: ',trim(msg) + call shr_sys_abort( msg ) +end subroutine wrf_error_fatal + diff --git a/share/esmf_wrf_timemgr/wrf_message.F90 b/share/esmf_wrf_timemgr/wrf_message.F90 new file mode 100644 index 000000000000..d7880d04703e --- /dev/null +++ b/share/esmf_wrf_timemgr/wrf_message.F90 @@ -0,0 +1,7 @@ + +SUBROUTINE wrf_message( str ) + IMPLICIT NONE + CHARACTER*(*) str + write(6,*) str +END SUBROUTINE wrf_message + diff --git a/share/timing/CMakeLists.txt b/share/timing/CMakeLists.txt new file mode 100644 index 000000000000..ad665f33b9ae --- /dev/null +++ b/share/timing/CMakeLists.txt @@ -0,0 +1,24 @@ +INCLUDE(FortranCInterface) +FortranCInterface_HEADER(cmake_fortran_c_interface.h + MACRO_NAMESPACE "FCI_") + +ADD_DEFINITIONS(${PIO_DEFINITIONS}) + +SET(TIMING_INCLUDE_DIRS ${CMAKE_CURRENT_SOURCE_DIR} + ${CMAKE_CURRENT_BINARY_DIR} + CACHE STRING "") +INCLUDE_DIRECTORIES(${TIMING_INCLUDE_DIRS}) + +ADD_DEFINITIONS(-DINCLUDE_CMAKE_FCI -DHAVE_MPI) + +SET(SRCS_C GPTLget_memusage.c + GPTLprint_memusage.c + GPTLutil.c + f_wrappers.c + gptl.c + gptl_papi.c) + +SET(SRCS_F90 perf_mod.F90 + perf_utils.F90) + +ADD_LIBRARY(timing ${SRCS_F90} ${SRCS_C}) diff --git a/share/timing/COPYING b/share/timing/COPYING new file mode 100644 index 000000000000..94a9ed024d38 --- /dev/null +++ b/share/timing/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/share/timing/ChangeLog b/share/timing/ChangeLog new file mode 100644 index 000000000000..8b3fc5ba3d84 --- /dev/null +++ b/share/timing/ChangeLog @@ -0,0 +1,189 @@ +timing_160320: Added routines t_set_prefixf and t_unset_prefixf. + Setting the prefix adds this to the beginning of all subsequent + timer event names (defined in t_startf/t_stopf). + Also doubling default hash index tablesize to 2048. + [Patrick Worley] +timing_160124: Added option to prefix timer names with detail level. This is + controlled by a new namelist variable (profile_add_detail). + The default is to not enable this option. It is meant to be + used for inspecting the profile detail definitions and + associated logic. + [Patrick Worley] +timing_150903: Changed API to be compatible with NCAR CIME version of timing + library: (a) changed handle argument from integer8 to integer + in t_startf and t_stopf, and disabled use of handles in these + routines until gptl.c can be updated; (b) added MaxThreads + optional argument to t_initf, though it does not do anything + yet. + [Patrick Worley] +timing_150518: Disabled abort when calling GPTL routines before GPTLinitialize + (so can use with Chombo library, for example); changed top + level default from nanotimer to MPI_WTIME. + [Patrick Worley] +timing_150327: Added option to more accurately measure measurement overhead + (incurring additional overhead, so not on by default). + [Patrick Worley] +timing_150217: Added support for enabling/disabling start/stop timers from + perf_mod even when calling GPTL routines directly from C/C++ + libraries; increased maximum timer name length. + [Patrick Worley] +timing_141119: Enabled cmake build of timing library. + [Jayesh Krishna] +timing_140805: Disabled GPTL autoinstrumentation, as this conflicts with the + VampirTrace tool. (We do not use the autoinstrumentation + capability.) [Patrick Worley, from B. Jamroz] +timing_140416: Changed Makefile so that .mods and the static library are copied to + LIBROOT +timing_140317: Modified Makefile to deal with shared mpi-serial builds +timing_131108: Added memory retrieval commands for BG/Q [S Mickelson] +timing_131023: Added explicit include path for gptl.h [J Edwards] +timing_130827: added routines supporting non-null terminated timer labels, for use with + with C++ std:string (and more efficient usage with Fortran); also CMake + logic fixes + [Patrick Worley] +timing_130506: Copy all modules to the include directory on install +timing_130417: Made nano time the default timer if available. +timing_130316: Changed declarations of functions used in qsort in gptl.c, to eliminate + error with Cray compiler (and warnings from other compilers) + [Patrick Worley] +timing_130214: NAG port: Put mpif.h include before "save", and don't use + "abort" and "flush" extensions for NAG. [Sean Patrick Santos] +timing_120921: Add code for cmake build, should not have any affect otherwise +timing_120731: Correction in Makefile for serial build [Jim Edwards] +timing_120728: Replace process subset optional parameter in t_prf with + outpe_thispe optional parameter. Change def_perf_outpe_num to 0. + [Patrick Worley] +timing_120717: Retain timestamp on cp in Makefile [Jim Edwards] +timing_120710: Correct issue in Makefile [Jim Edwards] +timing_120709: Change for BGP to measure on compute nodes rather than IO nodes only, + minor Change in Makefile so that gptl can build seperate from csm_share + in cesm [Jim Edwards] +timing_120512: Bug fix in global statistics logic for when a thread has no events + to contribute to the merge (mods to gptl.c) + [Patrick Worley] +timing_120419: Minor changes for mpi-serial compile (jedwards) +timing_120408: Make HAVE_COMM_F2C default to true. (jedwards) +timing_120110: Update to GPTL 4.1 source (mods to gptl.c and GPTLprint_memusage) + [Jim Rosinski (GPTL 4.1), Patrick Worley] +timing_120109: Bug fix (adding shr_kind_i8 to shr_kind_mod list) +timing_111205: Update to gptl 4.0 (introducing CESM customizations); + support for handles in t_startf/t_stopf; + support for restricting output to explicitly named process subsets + [Jim Rosinski (gptl 4.0), Patrick Worley] +timing_111101: Workaround for mpi_rsend issue on cray/gemini +timing_110928: Add a Makefile and build as a library usable by mct and pio +timing_101215: No changes from previous tag other than updating Changelog +timing_101210: Fix interface to cesm build system, add workaround for xlf bug +timing_101202: updated get_memusage and print_memusage from GPTL version 3.7; adds + improved support for MacOS and SLASHPROC + [Jim Rosinski, Chuck Bardeen (integrated by P. Worley)] +timing_091021: update to GPTL version 3.5; rewrite of GPTLpr_summary: much faster, merging + events from all processes and all threads (not just process 0/thread 0); + miscellaneous fixes + [Jim Rosinski (gptl 3.5), Joseph Singh, Patrick Worley] +timing_090929: added explicit support for the GPTL-native token HAVE_MPI (indicating + presence of MPI library) + [Patrick Worley] +timing_081221: restore default assumption that gettimeofday available +timing_081028: bug fix in include order in gptl_papi.c +timing_081026: change in output format to make postprocessing simpler +timing_081024: support for up to one million processes and writing timing files to + subdirectories +timing_081017: updated to gptl version 3_4_2. Changed some defaults. + [Jim Rosinski, Patrick Worley] +timing_080629: added optional parameters perf_outpe_num and perf_outpe_stride to t_prf. + These are used to override the user specified values for timing data + written out before the end of a simulation. + [Patrick Worley] +timing_071213: changed default to disable inline keyword; changed global statistics + logic to avoid problems at scale; moved shr and CAM routine equivalencies + to a new module (in perf_utils.F90); added t_getLogUnit/t_setLogUnit + routines to control Log output in same way as shr_file_get/setLogUnit; + modified GPTLpr logic to support output of timing data during a run + [Patrick Worley] +timing_071023: updated to gptl version 2.16, added support for output of global + statistics; removed dependencies on shr and CAM routines; renamed + gptlutil.c to GPTLutil.c + [Patrick Worley, Jim Rosinski] +timing_071019: modified namelist logic to abort if try to set unknown namelist parameters; + changed default number of reporting processes to 1; + reversed meaning and changed names of CPP tokens to NO_C99_INLINE and NO_VPRINTF + [Patrick Worley] +timing_071010: modified gptl.c to remove the 'inline' specification unless the + CPP token C99 is defined. + [Patrick Worley] +timing_070810: added ChangeLog + updated to latest version of GPTL (from Jim Rosinski) + modified perf_mod.F90: + - added perf_outpe_num and perf_outpe_stride to perf_inparm + namelist to control which processes output timing data + - added perf_papi_enable to perf_inparm namelist to enable + PAPI counters + - added papi_inparm namelist and papi_ctr1,2,3,4 namelist + parameters to specify PAPI counters + [Patrick Worley, Jim Rosinski] +timing_070525: bug fix in gptl.c + - unitialized pointer, testing for null pter + before traversing + [Patrick Worley] +timing_070328: modified perf_mod.F90 + - deleted HIDE_MPI cpp token + [Erik Kluzek] +timing_070327: bug fixes in gptl.c + - testing for null pters before traversing + links; added missing type declaration to GPTLallocate for sum + bug fixes in perf_mod.F90 + - fixed OMP-related logic, modified settings reporting, + modified to work when namelist input is + missing; moved timer depth logic back into gptl.c + [Patrick Worley] +timing_070308: added perf_mod.F90 + - defines all t_xxx entry points - calling gptlxxx directly + and removing all external gptlxxx dependencies, + added detail option as an alternative way to disable + event timing, added runtime selection of timing_disable, + perf_timer, timer_depth_limit, timing_detail_limit, + timing_barrier, perf_single_file via namelist parameters + modified f_wrappers.c + - replaced all t_xxx entry points with gptlxxx entry points, + added new gptlxxx entry points, deleted _fcd support + modified gptl.c + - deleted DISABLE_TIMERS cpp token, modified GPTLpr call + and logic to move some of support for concatenating timing + output into a single file to perf_mod.F90 + modified gptl.h + - exposed gptlxxx entry points and to add support for choice + of GPTL timer + modified gptl.inc + - removed t_xxx entry points and expose gptlxxx entry points + [Patrick Worley] +timing_061207: modified gptl.c + - improved event output ordering + [Jim Edwards] +timing_061124: modified gptl.c + - modified GPTLpr to add option to concatenate + all timing data in a single output file, added GPTL_enable + and GPTL_disable as runtime control of event timing, + process 0-only reporting of timing options - unless DEBUG + cpp token defined + modified gptl.h + - redefined GPTLpr parameters + modified f_wrappers.c + - added t_enablef and t_disablef to call GPTL_enable and + GPTL_disable, added t_pr_onef, added string.h include + bug fix in f_wrappers.c + - changed character string size declaration from int to size_t + bug fix in gptl_papi.c + - modified error message - from Jim Edwards + modified private.h + - increased maximum event name length + [Patrick Worley] +timing_061028: modified f_wrappers.c + - deleted dependency on cfort.h + [Patrick Worley] +timing_060524: modified f_wrappers.c + - added support for CRAY cpp token and fixed routine + type declarations + [Patrick Worley] +timing_051212: original subversion version + - see CAM ChangeLog for earlier history diff --git a/share/timing/GPTLget_memusage.c b/share/timing/GPTLget_memusage.c new file mode 100644 index 000000000000..4835263f7459 --- /dev/null +++ b/share/timing/GPTLget_memusage.c @@ -0,0 +1,179 @@ +/* +** $Id: get_memusage.c,v 1.10 2010-11-09 19:08:53 rosinski Exp $ +** +** Author: Jim Rosinski +** Credit to Chuck Bardeen for MACOS section (__APPLE__ ifdef) +** +** get_memusage: +** +** Designed to be called from Fortran, returns information about memory +** usage in each of 5 input int* args. On Linux read from the /proc +** filesystem because getrusage() returns placebos (zeros). Return -1 for +** values which are unavailable or ambiguous on a particular architecture. +** +** Return value: 0 = success +** -1 = failure +*/ + +#include +#include "gptl.h" /* additional cpp defs and function prototypes */ + +/* _AIX is automatically defined when using the AIX C compilers */ +#ifdef _AIX +#include +#endif + +#ifdef IRIX64 +#include +#endif + +#ifdef HAVE_SLASHPROC + +#include +#include +#include +#include + +#elif (defined __APPLE__) + +#include +#include +#include + +#endif + +#ifdef BGP + +#include +#include +#include +#include +#define Personality _BGP_Personality_t + +#endif + +#ifdef BGQ + +#include +#include + +#endif + +int GPTLget_memusage (int *size, int *rss, int *share, int *text, int *datastack) +{ +#if defined (BGP) || defined(BGQ) + + long long alloc; + struct mallinfo m; +#if defined (BGP) + Personality pers; +#endif +#if defined (BGQ) + uint64_t shared_mem_count; +#endif + long long total; + int node_config; + + /* memory available */ +#if defined(BGP) + Kernel_GetPersonality(&pers, sizeof(pers)); + total = BGP_Personality_DDRSizeMB(&pers); + + node_config = BGP_Personality_processConfig(&pers); + if (node_config == _BGP_PERS_PROCESSCONFIG_VNM) total /= 4; + else if (node_config == _BGP_PERS_PROCESSCONFIG_2x2) total /= 2; + total *= 1024*1024; + + *size = total; +#endif + +#if defined(BGQ) + Kernel_GetMemorySize(KERNEL_MEMSIZE_SHARED, &shared_mem_count); + + shared_mem_count *= 1024*1024; + *size = shared_mem_count; + +#endif + /* total memory used - heap only (not static memory)*/ + + m = mallinfo(); + alloc = m.hblkhd + m.uordblks; + + *rss = alloc; + *share = -1; + *text = -1; + *datastack = -1; + + +#elif (defined HAVE_SLASHPROC) + FILE *fd; /* file descriptor for fopen */ + int pid; /* process id */ + static char *head = "/proc/"; /* part of path */ + static char *tail = "/statm"; /* part of path */ + char file[19]; /* full path to file in /proc */ + int dum; /* placeholder for unused return arguments */ + int ret; /* function return value */ + + /* + ** The file we want to open is /proc//statm + */ + + pid = (int) getpid (); + if (pid > 999999) { + fprintf (stderr, "get_memusage: pid %d is too large\n", pid); + return -1; + } + + sprintf (file, "%s%d%s", head, pid, tail); + if ((fd = fopen (file, "r")) < 0) { + fprintf (stderr, "get_memusage: bad attempt to open %s\n", file); + return -1; + } + + /* + ** Read the desired data from the /proc filesystem directly into the output + ** arguments, close the file and return. + */ + + ret = fscanf (fd, "%d %d %d %d %d %d %d", + size, rss, share, text, datastack, &dum, &dum); + ret = fclose (fd); + return 0; + +#elif (defined __APPLE__) + + FILE *fd; + char cmd[60]; + int pid = (int) getpid (); + + sprintf (cmd, "ps -o vsz -o rss -o tsiz -p %d | grep -v RSS", pid); + fd = popen (cmd, "r"); + + if (fd) { + fscanf (fd, "%d %d %d", size, rss, text); + *share = -1; + *datastack = -1; + (void) pclose (fd); + } + + return 0; + +#else + + struct rusage usage; /* structure filled in by getrusage */ + + if (getrusage (RUSAGE_SELF, &usage) < 0) + return -1; + + *size = -1; + *rss = usage.ru_maxrss; + *share = -1; + *text = -1; + *datastack = -1; +#ifdef IRIX64 + *datastack = usage.ru_idrss + usage.ru_isrss; +#endif + return 0; + +#endif +} diff --git a/share/timing/GPTLprint_memusage.c b/share/timing/GPTLprint_memusage.c new file mode 100644 index 000000000000..5ab873dccb46 --- /dev/null +++ b/share/timing/GPTLprint_memusage.c @@ -0,0 +1,120 @@ +/* +** $Id: print_memusage.c,v 1.13 2010-11-09 19:08:54 rosinski Exp $ +** +** Author: Jim Rosinski +** +** print_memusage: +** +** Prints info about memory usage of this process by calling get_memusage. +** +** Return value: 0 = success +** -1 = failure +*/ + +#include "gptl.h" +#include +#include +#include + +static int nearest_powerof2 (const int); +static int convert_to_mb = 1; /* true */ + +int GPTLprint_memusage (const char *str) +{ + int size, size2; /* process size (returned from OS) */ + int rss, rss2; /* resident set size (returned from OS) */ + int share, share2; /* shared data segment size (returned from OS) */ + int text, text2; /* text segment size (returned from OS) */ + int datastack, datastack2; /* data/stack size (returned from OS) */ + static int bytesperblock = -1; /* convert to bytes (init to invalid) */ + static const int nbytes = 1024*1024*10; /* allocate 10 MB */ + static double blockstomb; /* convert blocks to MB */ + void *space; /* allocated space */ + + if (GPTLget_memusage (&size, &rss, &share, &text, &datastack) < 0) + return -1; + +#if (defined HAVE_SLASHPROC || defined __APPLE__) + /* + ** Determine size in bytes of memory usage info presented by the OS. Method: allocate a + ** known amount of memory and see how much bigger the process becomes. + */ + + if (convert_to_mb && bytesperblock == -1 && (space = malloc (nbytes))) { + memset (space, 0, nbytes); /* ensure the space is really allocated */ + if (GPTLget_memusage (&size2, &rss2, &share2, &text2, &datastack2) == 0) { + if (size2 > size) { + /* + ** Estimate bytes per block, then refine to nearest power of 2. + ** The assumption is that the OS presents memory usage info in + ** units that are a power of 2. + */ + bytesperblock = (int) ((nbytes / (double) (size2 - size)) + 0.5); + bytesperblock = nearest_powerof2 (bytesperblock); + blockstomb = bytesperblock / (1024.*1024.); + printf ("GPTLprint_memusage: Using bytesperblock=%d\n", bytesperblock); + } + } + free (space); + } + + if (bytesperblock > 0) + printf ("%s size=%.1f MB rss=%.1f MB share=%.1f MB text=%.1f MB datastack=%.1f MB\n", + str, size*blockstomb, rss*blockstomb, share*blockstomb, + text*blockstomb, datastack*blockstomb); + else + printf ("%s size=%d rss=%d share=%d text=%d datastack=%d\n", + str, size, rss, share, text, datastack); + +#else + + /* + ** Use max rss as returned by getrusage. If someone knows how to + ** get the process size under AIX please tell me. + */ + + bytesperblock = 1024; + blockstomb = bytesperblock / (1024.*1024.); + if (convert_to_mb) + printf ("%s max rss=%.1f MB\n", str, rss*blockstomb); + else + printf ("%s max rss=%d\n", str, rss); +#endif + + return 0; +} + +/* +** nearest_powerof2: +** Determine nearest integer which is a power of 2. +** Note: algorithm can't use anything that requires -lm because this is a library, +** and we don't want to burden the user with having to add extra libraries to the +** link line. +** +** Input arguments: +** val: input integer +** +** Return value: nearest integer to val which is a power of 2 +*/ + +static int nearest_powerof2 (const int val) +{ + int lower; /* power of 2 which is just less than val */ + int higher; /* power of 2 which is just more than val */ + int delta1; /* difference between val and lower */ + int delta2; /* difference between val and higher */ + + if (val < 2) + return 0; + + for (higher = 1; higher < val; higher *= 2) + lower = higher; + + delta1 = val - lower; + delta2 = higher - val; + + if (delta1 < delta2) + return lower; + else + return higher; +} diff --git a/share/timing/GPTLutil.c b/share/timing/GPTLutil.c new file mode 100644 index 000000000000..b1c7cf80df48 --- /dev/null +++ b/share/timing/GPTLutil.c @@ -0,0 +1,82 @@ +/* +** $Id: util.c,v 1.13 2010-01-01 01:34:07 rosinski Exp $ +*/ + +#include +#include +#include + +#include "private.h" + +static bool abort_on_error = false; /* flag says to abort on any error */ +static int max_error = 500; /* max number of error print msgs */ + +/* +** GPTLerror: error return routine to print a message and return a failure +** value. +** +** Input arguments: +** fmt: format string +** variable list of additional arguments for vfprintf +** +** Return value: -1 (failure) +*/ + +int GPTLerror (const char *fmt, ...) +{ + va_list args; + + va_start (args, fmt); + static int num_error = 0; + + if (fmt != NULL && num_error < max_error) { +#ifndef NO_VPRINTF + (void) vfprintf (stderr, fmt, args); +#else + (void) fprintf (stderr, "GPTLerror: no vfprintf: fmt is %s\n", fmt); +#endif + if (num_error == max_error) + (void) fprintf (stderr, "Truncating further error print now after %d msgs", + num_error); + ++num_error; + } + + va_end (args); + + if (abort_on_error) + exit (-1); + + return (-1); +} + +/* +** GPTLset_abort_on_error: User-visible routine to set abort_on_error flag +** +** Input arguments: +** val: true (abort on error) or false (don't) +*/ + +void GPTLset_abort_on_error (bool val) +{ + abort_on_error = val; +} + +/* +** GPTLallocate: wrapper utility for malloc +** +** Input arguments: +** nbytes: size to allocate +** +** Return value: pointer to the new space (or NULL) +*/ + +void *GPTLallocate (const int nbytes) +{ + void *ptr; + + if ( nbytes <= 0 || ! (ptr = malloc (nbytes))) + (void) GPTLerror ("GPTLallocate: malloc failed for %d bytes\n", nbytes); + + return ptr; +} + diff --git a/share/timing/Makefile b/share/timing/Makefile new file mode 100644 index 000000000000..160e785fe46b --- /dev/null +++ b/share/timing/Makefile @@ -0,0 +1,89 @@ +.SUFFIXES: +.SUFFIXES: .F90 .o .c .f90 +# name of macros file - but default this is generic + +VPATH := $(GPTL_DIR) + +# Determine whether to compile threaded or not +ifeq ($(strip $(BUILD_THREADED)),TRUE) + compile_threaded = true +endif +ifeq ($(strip $(SMP)),TRUE) + compile_threaded = true +endif + + +ifndef MOD_SUFFIX + MOD_SUFFIX := mod +endif + + +ifeq ($(strip $(MACFILE)),) + MACFILE := Macros +endif + +# Machine specific macros file +# This must be included before any settings are overwritten +# But must be AFTER any definitions it uses are defined. +# So be careful if moving this either earlier or later in the makefile!!! +include $(MACFILE) + +INCLDIR += -I$(GPTL_DIR) + +ifeq ($(strip $(MPILIB)), mpi-serial) + CC := $(SCC) + FC := $(SFC) + MPIFC := $(SFC) + MPICC := $(SCC) + INCLDIR += -I$(GPTL_LIBDIR)/../mct/mpi-serial +else + CC := $(MPICC) + FC := $(MPIFC) + CPPDEFS += -DHAVE_MPI +endif +ifdef CPRE + FPPDEFS := $(patsubst -D%,$(CPRE)%,$(CPPDEFS)) +else + FPPDEFS := $(CPPDEFS) +endif + + + +OBJS = gptl.o GPTLutil.o GPTLget_memusage.o GPTLprint_memusage.o \ + gptl_papi.o f_wrappers.o perf_mod.o perf_utils.o + + +libgptl.a: $(OBJS) + $(AR) ruv $@ $(OBJS) + + + +.c.o: + $(CC) -c $(INCLDIR) $(INCS) $(CFLAGS) $(CPPDEFS) $< +.F.o: + $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FPPDEFS) $(FIXEDFLAGS) $< +.f90.o: + $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FREEFLAGS) $< +.F90.o: + $(FC) -c $(INCLDIR) $(INCS) $(FFLAGS) $(FPPDEFS) $(FREEFLAGS) $< + +mostlyclean: + $(RM) -f *.f *.f90 + +clean: + $(RM) -f *.f *.f90 *.d *.$(MOD_SUFFIX) $(OBJS) + + +install: libgptl.a + cp -p $(GPTL_DIR)/gptl.h $(SHAREDPATH)/include + cp -p *.$(MOD_SUFFIX) $(SHAREDPATH)/include + cp -p libgptl.a $(SHAREDPATH)/lib + + +perf_mod.o: perf_utils.o +f_wrappers.o: gptl.h private.h +f_wrappers_pmpi.o: gptl.h private.h +gptl.o: gptl.h private.h +util.o: gptl.h private.h +gptl_papi.o: gptl.h private.h +pmpi.o: gptl.h private.h diff --git a/share/timing/README b/share/timing/README new file mode 100644 index 000000000000..2f0991da2188 --- /dev/null +++ b/share/timing/README @@ -0,0 +1,143 @@ +This file contains information about using GPTL. For information on building +and installing GPTL, see the file INSTALL. + +GPTL is the "General Purpose Timing Library". It can be used to manually +instrument application codes with an arbitrary set of "regions" (or "timers") +over which statistics such as wallclock time and CPU time are gathered and +subsequently printed. If the target application is built with the GNU +compilers (gcc or gfortran) or Pathscale (pathcc or pathf95), GPTL can also be +used to automatically instrument regions which are defined by function entry +and exit points. This is an easy way to generate a dynamic call tree. See +Auto-Instrumentation below for a description of how to use this feature. + +If the PAPI library is installed (http://icl.cs.utk.edu/papi), GPTL +also provides a convenient mechanism to access all available PAPI events. In +addtion to PAPI preset and native events, GPTL defines derived events which +are based on PAPI counters. See gptl.h for a list of available derived events. +Of course these events can only be enabled if the PAPI counters they require +are available on the target architecture. + + +Using GPTL +---------- + +C codes making GPTL library calls should #include . Fortran codes +should #include or Fortran include 'gptl.inc'. The C and Fortran interfaces +are identical, except that the C interface uses mixed case. All +user-accessible functions return either 0 (success) or -1 (failure). Example +codes that use the library can be found in subdirectories ctests/ and ftests/. + +Code instrumentation to utilize GPTL involves zero or more calls to +GPTLsetoption(), then a single call to GPTLinitialize(), then an arbitrary +sequence of calls to GPTLstart() and GPTLstop(), and finally a call to +GPTLpr() or GPTLpr_file(). See "Example" below for a sample calling +sequence. Calls to GPTLstart() and GPTLstop() are thread-safe, with per-thread +statistics printed by GPTLpr() or GPTLpr_file(). + +The purpose of GPTLsetoption() is to enable or disable various library +options. For example, to enable the PAPI counter for total cycles, do this: + +ret = GPTLsetoption (PAPI_TOT_CYC, 1); + +The "1" says "enable". Use "0" for "disable". See the man pages for complete +documentation on function usage and arguments. The list of available GPTL +options is contained in gptl.h, and a complete list of available PAPI-based +events can be found by running "ctests/avail". + +GPTLinitialize() initializes the GPTL library. + +There can be an arbitrary number of start/stop pairs before GPTLpr() or +GPTLpr_file() is called to print the results. And an arbitrary amount of +nesting of regions is also allowed. The printed results will be indented to +indicate the level of nesting for each region. + +GPTLpr() prints the results to a file named timing., where the single +argument is an integer. For MPI jobs, it is most convenient to use +the MPI rank of the invoking task for . Equivalently, function +GPTLpr_file() can be called. Its input argument is a character string +indicating the output file name to be written. It is up to the user to ensure +that these print functions write to uniquely-named files, in order to avoid +name-space collisions. + +GPTLfinalize() can be called to clean up the GPTL environment. All space +malloc'ed by the GPTL library will be freed by this call. + + +Example +------- + +From "man GPTLstart", a simple example calling sequence to time a couple of +code regions and print the results is: + +(void) GPTLsetoption (GPTLcpu, 1); /* enable cpu timings */ +(void) GPTLsetoption (GPTLwall, 0); /* disable wallclock timings */ +(void) GPTLsetoption (PAPI_TOT_CYC, 1); /* enable counting of total cycles */ +... +(void) GPTLinitialize(); /* initialize the GPTL library */ +(void) GPTLstart ("total"); /* start a timer */ +... +(void) GPTLstart ("do_work"); /* start another timer */ + +do_work(); /* do some work */ + +(void) GPTLstop ("do_work"); /* stop a timer */ +(void) GPTLstop ("total"); /* stop a timer */ +... +(void) GPTLpr (mympitaskid); /* print the results to timing. */ + + +Auto-instrumentation +-------------------- + +If the regions to be timed are defined by function entry and exit points, and +the application to be profiled is built with either the GNU or Pathscale +compilers, you might find it convenient to use the auto-instrumentation +feature of GPTL. Here's how: + +1) Add the flag -finstrument-functions when compiling the routines you'd like +to profile. + +2) Add calls to GPTLsetoption() (if desired), and GPTLinitialize() to the main +program before any other routines are invoked. + +3) Add a call to GPTLpr() or GPTLpr_file() wherever appropriate prior to where +the code terminates. + +4) Link with -lgptl (and -lpapi if PAPI is enabled). + +5) Run the code. + +6) Run "hex2name.pl | less", where + is the name of the executable, and is the name of the +timing file to be converted. + +The result should be a dynamic call tree with timings and (if enabled) PAPI +counts and derived event statistics for each region, where regions are defined +by function entry and exit points. + +Here's what's happening under the covers: + +The -finstrument-functions flag tells the compiler to insert calls to +__cyg_profile_func_enter (void *this_fn, void *call_site) at function start, +and __cyg_profile_func_exit (void *this_fn, void *call_site) at function +exit. GPTL defines these functions as calls to (effectively) GPTLstart() and +GPTLstop(), where the address of the function is used as the input sentinel to +these routines. + +Running hex2name.pl converts the function addresses back to human-readable +function names. It uses the UNIX "nm" utility to do this. + + +Multi-processor instrumented codes +---------------------------------- + +For instrumented codes which make use of threading and/or MPI, a +post-processing script is provided to analyze GPTL output files and gather +max/min/average stats on a per-region basis. The script is parsegptlout.pl. It +might be invoked as, for example: + +parsegptlout.pl sub1 + +The script will look through all files in the current directory named timing.* +for regions named "sub1", then gather and print various statistics. Numerous +options are available. See "man parsegptlout" for more in-depth information. diff --git a/share/timing/f_wrappers.c b/share/timing/f_wrappers.c new file mode 100644 index 000000000000..a823660cd03b --- /dev/null +++ b/share/timing/f_wrappers.c @@ -0,0 +1,545 @@ +/* +** $Id: f_wrappers.c,v 1.56 2010-12-29 18:46:42 rosinski Exp $ +** +** Author: Jim Rosinski +** +** Fortran wrappers for timing library routines +*/ + +#include +#include +#include "private.h" /* MAX_CHARS, bool */ +#include "gptl.h" /* function prototypes and HAVE_MPI logic*/ + +#if ( defined FORTRANCAPS ) + +#define gptlinitialize GPTLINITIALIZE +#define gptlfinalize GPTLFINALIZE +#define gptlpr_set_append GPTLPR_SET_APPEND +#define gptlpr_query_append GPTLPR_QUERY_APPEND +#define gptlpr_set_write GPTLPR_SET_WRITE +#define gptlpr_query_write GPTLPR_QUERY_WRITE +#define gptlpr GPTLPR +#define gptlpr_file GPTLPR_FILE +#define gptlpr_summary GPTLPR_SUMMARY +#define gptlpr_summary_FILE GPTLPR_SUMMARY_FILE +#define gptlbarrier GPTLBARRIER +#define gptlreset GPTLRESET +#define gptlstamp GPTLSTAMP +#define gptlstart GPTLSTART +#define gptlstart_handle GPTLSTART_HANDLE +#define gptlstop GPTLSTOP +#define gptlstop_handle GPTLSTOP_HANDLE +#define gptlsetoption GPTLSETOPTION +#define gptlenable GPTLENABLE +#define gptldisable GPTLDISABLE +#define gptlsetutr GPTLSETUTR +#define gptlquery GPTLQUERY +#define gptlquerycounters GPTLQUERYCOUNTERS +#define gptlget_wallclock GPTLGET_WALLCLOCK +#define gptlget_eventvalue GPTLGET_EVENTVALUE +#define gptlget_nregions GPTLGET_NREGIONS +#define gptlget_regionname GPTLGET_REGIONNAME +#define gptlget_memusage GPTLGET_MEMUSAGE +#define gptlprint_memusage GPTLPRINT_MEMUSAGE +#define gptl_papilibraryinit GPTL_PAPILIBRARYINIT +#define gptlevent_name_to_code GPTLEVENT_NAME_TO_CODE +#define gptlevent_code_to_name GPTLEVENT_CODE_TO_NAME + +#elif ( defined INCLUDE_CMAKE_FCI ) + +#define gptlinitialize FCI_GLOBAL(gptlinitialize,GPTLINITIALIZE) +#define gptlfinalize FCI_GLOBAL(gptlfinalize,GPTLFINALIZE) +#define gptlpr_set_append FCI_GLOBAL(gptlpr_set_append,GPTLPR_SET_APPEND) +#define gptlpr_query_append FCI_GLOBAL(gptlpr_query_append,GPTLPR_QUERY_APPEND) +#define gptlpr_set_write FCI_GLOBAL(gptlpr_set_write,GPTLPR_SET_WRITE) +#define gptlpr_query_write FCI_GLOBAL(gptlpr_query_write,GPTLPR_QUERY_WRITE) +#define gptlpr FCI_GLOBAL(gptlpr,GPTLPR) +#define gptlpr_file FCI_GLOBAL(gptlpr_file,GPTLPR_FILE) +#define gptlpr_summary FCI_GLOBAL(gptlpr_summary,GPTLPR_SUMMARY) +#define gptlpr_summary_file FCI_GLOBAL(gptlpr_summary_file,GPTLPR_SUMMARY_FILE) +#define gptlbarrier FCI_GLOBAL(gptlbarrier,GPTLBARRIER) +#define gptlreset FCI_GLOBAL(gptlreset,GPTLRESET) +#define gptlstamp FCI_GLOBAL(gptlstamp,GPTLSTAMP) +#define gptlstart FCI_GLOBAL(gptlstart,GPTLSTART) +#define gptlstart_handle FCI_GLOBAL(gptlstart_handle,GPTLSTART_HANDLE) +#define gptlstop FCI_GLOBAL(gptlstop,GPTLSTOP) +#define gptlstop_handle FCI_GLOBAL(gptlstop_handle,GPTLSTOP_HANDLE) +#define gptlsetoption FCI_GLOBAL(gptlsetoption,GPTLSETOPTION) +#define gptlenable FCI_GLOBAL(gptlenable,GPTLENABLE) +#define gptldisable FCI_GLOBAL(gptldisable,GPTLDISABLE) +#define gptlsetutr FCI_GLOBAL(gptlsetutr,GPTLSETUTR) +#define gptlquery FCI_GLOBAL(gptlquery,GPTLQUERY) +#define gptlquerycounters FCI_GLOBAL(gptlquerycounters,GPTLQUERYCOUNTERS) +#define gptlget_wallclock FCI_GLOBAL(gptlget_wallclock,GPTLGET_WALLCLOCK) +#define gptlget_eventvalue FCI_GLOBAL(gptlget_eventvalue,GPTLGET_EVENTVALUE) +#define gptlget_nregions FCI_GLOBAL(gptlget_nregions,GPTLGET_NREGIONS) +#define gptlget_regionname FCI_GLOBAL(gptlget_regionname,GPTLGET_REGIONNAME) +#define gptlget_memusage FCI_GLOBAL(gptlget_memusage,GPTLGET_MEMUSAGE) +#define gptlprint_memusage FCI_GLOBAL(gptlprint_memusage,GPTLPRINT_MEMUSAGE) +#define gptl_papilibraryinit FCI_GLOBAL(gptl_papilibraryinit,GPTL_PAPILIBRARYINIT) +#define gptlevent_name_to_code FCI_GLOBAL(gptlevent_name_to_code,GPTLEVENT_NAME_TO_CODE) +#define gptlevent_code_to_name FCI_GLOBAL(gptlevent_code_to_name,GPTLEVENT_CODE_TO_NAME) + +#elif ( defined FORTRANUNDERSCORE ) + +#define gptlinitialize gptlinitialize_ +#define gptlfinalize gptlfinalize_ +#define gptlpr_set_append gptlpr_set_append_ +#define gptlpr_query_append gptlpr_query_append_ +#define gptlpr_set_write gptlpr_set_write_ +#define gptlpr_query_write gptlpr_query_write_ +#define gptlpr gptlpr_ +#define gptlpr_file gptlpr_file_ +#define gptlpr_summary gptlpr_summary_ +#define gptlpr_summary_file gptlpr_summary_file_ +#define gptlbarrier gptlbarrier_ +#define gptlreset gptlreset_ +#define gptlstamp gptlstamp_ +#define gptlstart gptlstart_ +#define gptlstart_handle gptlstart_handle_ +#define gptlstop gptlstop_ +#define gptlstop_handle gptlstop_handle_ +#define gptlsetoption gptlsetoption_ +#define gptlenable gptlenable_ +#define gptldisable gptldisable_ +#define gptlsetutr gptlsetutr_ +#define gptlquery gptlquery_ +#define gptlquerycounters gptlquerycounters_ +#define gptlget_wallclock gptlget_wallclock_ +#define gptlget_eventvalue gptlget_eventvalue_ +#define gptlget_nregions gptlget_nregions_ +#define gptlget_regionname gptlget_regionname_ +#define gptlget_memusage gptlget_memusage_ +#define gptlprint_memusage gptlprint_memusage_ +#define gptl_papilibraryinit gptl_papilibraryinit_ +#define gptlevent_name_to_code gptlevent_name_to_code_ +#define gptlevent_code_to_name gptlevent_code_to_name_ + +#elif ( defined FORTRANDOUBLEUNDERSCORE ) + +#define gptlinitialize gptlinitialize__ +#define gptlfinalize gptlfinalize__ +#define gptlpr_set_append gptlpr_set_append__ +#define gptlpr_query_append gptlpr_query_append__ +#define gptlpr_set_write gptlpr_set_write__ +#define gptlpr_query_write gptlpr_query_write__ +#define gptlpr gptlpr__ +#define gptlpr_file gptlpr_file__ +#define gptlpr_summary gptlpr_summary__ +#define gptlpr_summary_file gptlpr_summary_file__ +#define gptlbarrier gptlbarrier__ +#define gptlreset gptlreset__ +#define gptlstamp gptlstamp__ +#define gptlstart gptlstart__ +#define gptlstart_handle gptlstart_handle__ +#define gptlstop gptlstop__ +#define gptlstop_handle gptlstop_handle__ +#define gptlsetoption gptlsetoption__ +#define gptlenable gptlenable__ +#define gptldisable gptldisable__ +#define gptlsetutr gptlsetutr__ +#define gptlquery gptlquery__ +#define gptlquerycounters gptlquerycounters__ +#define gptlget_wallclock gptlget_wallclock__ +#define gptlget_eventvalue gptlget_eventvalue__ +#define gptlget_nregions gptlget_nregions__ +#define gptlget_regionname gptlget_regionname__ +#define gptlget_memusage gptlget_memusage__ +#define gptlprint_memusage gptlprint_memusage__ +#define gptl_papilibraryinit gptl_papilibraryinit__ +#define gptlevent_name_to_code gptlevent_name_to_code__ +#define gptlevent_code_to_name gptlevent_code_to_name__ + +#endif + +/* +** Local function prototypes +*/ + +int gptlinitialize (void); +int gptlfinalize (void); +int gptlpr_set_append (void); +int gptlpr_query_append (void); +int gptlpr_set_write (void); +int gptlpr_query_write (void); +int gptlpr (int *procid); +int gptlpr_file (char *file, int nc1); +int gptlpr_summary (int *fcomm); +int gptlpr_summary_file (int *fcomm, char *name, int nc1); +int gptlbarrier (int *fcomm, char *name, int nc1); +int gptlreset (void); +int gptlstamp (double *wall, double *usr, double *sys); +int gptlstart (char *name, int nc1); +int gptlstart_handle (char *name, void **, int nc1); +int gptlstop (char *name, int nc1); +int gptlstop_handle (char *name, void **, int nc1); +int gptlsetoption (int *option, int *val); +int gptlenable (void); +int gptldisable (void); +int gptlsetutr (int *option); +int gptlquery (const char *name, int *t, int *count, int *onflg, double *wallclock, + double *usr, double *sys, long long *papicounters_out, int *maxcounters, + int nc); +int gptlquerycounters (const char *name, int *t, long long *papicounters_out, int nc); +int gptlget_wallclock (const char *name, int *t, double *value, int nc); +int gptlget_eventvalue (const char *timername, const char *eventname, int *t, double *value, + int nc1, int nc2); +int gptlget_nregions (int *t, int *nregions); +int gptlget_regionname (int *t, int *region, char *name, int nc); +int gptlget_memusage (int *size, int *rss, int *share, int *text, int *datastack); +int gptlprint_memusage (const char *str, int nc); +#ifdef HAVE_PAPI +int gptl_papilibraryinit (void); +int gptlevent_name_to_code (const char *str, int *code, int nc); +int gptlevent_code_to_name (int *code, char *str, int nc); +#endif + +/* +** Fortran wrapper functions start here +*/ + +int gptlinitialize (void) +{ + return GPTLinitialize (); +} + +int gptlfinalize (void) +{ + return GPTLfinalize (); +} + +int gptlpr_set_append (void) +{ + return GPTLpr_set_append (); +} + +int gptlpr_query_append (void) +{ + return GPTLpr_set_append (); +} + +int gptlpr_set_write (void) +{ + return GPTLpr_set_append (); +} + +int gptlpr_query_write (void) +{ + return GPTLpr_set_append (); +} + +int gptlpr (int *procid) +{ + return GPTLpr (*procid); +} + +int gptlpr_file (char *file, int nc1) +{ + char *locfile; + int ret; + + if ( ! (locfile = (char *) malloc (nc1+1))) + return GPTLerror ("gptlpr_file: malloc error\n"); + + snprintf (locfile, nc1+1, "%s", file); + + ret = GPTLpr_file (locfile); + free (locfile); + return ret; +} + +int gptlpr_summary (int *fcomm) +{ +#ifdef HAVE_MPI + MPI_Comm ccomm; +#ifdef HAVE_COMM_F2C + ccomm = MPI_Comm_f2c (*fcomm); +#else + /* Punt and try just casting the Fortran communicator */ + ccomm = (MPI_Comm) *fcomm; +#endif +#else + int ccomm = 0; +#endif + + return GPTLpr_summary (ccomm); +} + +int gptlpr_summary_file (int *fcomm, char *file, int nc1) +{ + char *locfile; + int ret; + +#ifdef HAVE_MPI + MPI_Comm ccomm; +#ifdef HAVE_COMM_F2C + ccomm = MPI_Comm_f2c (*fcomm); +#else + /* Punt and try just casting the Fortran communicator */ + ccomm = (MPI_Comm) *fcomm; +#endif +#else + int ccomm = 0; +#endif + + if ( ! (locfile = (char *) malloc (nc1+1))) + return GPTLerror ("gptlpr_summary_file: malloc error\n"); + + snprintf (locfile, nc1+1, "%s", file); + + ret = GPTLpr_summary_file (ccomm, locfile); + free (locfile); + return ret; +} + +int gptlbarrier (int *fcomm, char *name, int nc1) +{ + char cname[MAX_CHARS+1]; + int numchars; +#ifdef HAVE_MPI + MPI_Comm ccomm; +#ifdef HAVE_COMM_F2C + ccomm = MPI_Comm_f2c (*fcomm); +#else + /* Punt and try just casting the Fortran communicator */ + ccomm = (MPI_Comm) *fcomm; +#endif +#else + int ccomm = 0; +#endif + + numchars = MIN (nc1, MAX_CHARS); + strncpy (cname, name, numchars); + cname[numchars] = '\0'; + return GPTLbarrier (ccomm, cname); +} + +int gptlreset (void) +{ + return GPTLreset(); +} + +int gptlstamp (double *wall, double *usr, double *sys) +{ + return GPTLstamp (wall, usr, sys); +} + +int gptlstart (char *name, int nc1) +{ + /* char cname[MAX_CHARS+1]; */ + /* int numchars; */ + + /* numchars = MIN (nc1, MAX_CHARS);*/ + /* strncpy (cname, name, numchars);*/ + /* cname[numchars] = '\0';*/ + /* return GPTLstart (cname);*/ + return GPTLstartf (name, nc1); +} + +int gptlstart_handle (char *name, void **handle, int nc1) +{ + /* char cname[MAX_CHARS+1];*/ + /* int numchars;*/ + + /* if (*handle) {*/ + /* cname[0] = '\0';*/ + /* } else {*/ + /* numchars = MIN (nc1, MAX_CHARS);*/ + /* strncpy (cname, name, numchars);*/ + /* cname[numchars] = '\0';*/ + /* }*/ + /* return GPTLstart_handle (cname, handle);*/ + return GPTLstartf_handle (name, nc1, handle); +} + +int gptlstop (char *name, int nc1) +{ + /* char cname[MAX_CHARS+1];*/ + /* int numchars;*/ + + /* numchars = MIN (nc1, MAX_CHARS);*/ + /* strncpy (cname, name, numchars);*/ + /* cname[numchars] = '\0';*/ + /* return GPTLstop (cname);*/ + return GPTLstopf (name, nc1); +} + +int gptlstop_handle (char *name, void **handle, int nc1) +{ + /* char cname[MAX_CHARS+1];*/ + /* int numchars;*/ + + /* if (*handle) {*/ + /* cname[0] = '\0';*/ + /* } else {*/ + /* numchars = MIN (nc1, MAX_CHARS);*/ + /* strncpy (cname, name, numchars);*/ + /* cname[numchars] = '\0';*/ + /* }*/ + /* return GPTLstop_handle (cname, handle);*/ + return GPTLstopf_handle (name, nc1, handle); +} + +int gptlsetoption (int *option, int *val) +{ + return GPTLsetoption (*option, *val); +} + +int gptlenable (void) +{ + return GPTLenable (); +} + +int gptldisable (void) +{ + return GPTLdisable (); +} + +int gptlsetutr (int *option) +{ + return GPTLsetutr (*option); +} + +int gptlquery (const char *name, int *t, int *count, int *onflg, double *wallclock, + double *usr, double *sys, long long *papicounters_out, int *maxcounters, + int nc) +{ + char cname[MAX_CHARS+1]; + int numchars; + + numchars = MIN (nc, MAX_CHARS); + strncpy (cname, name, numchars); + cname[numchars] = '\0'; + return GPTLquery (cname, *t, count, onflg, wallclock, usr, sys, papicounters_out, *maxcounters); +} + +int gptlquerycounters (const char *name, int *t, long long *papicounters_out, int nc) +{ + char cname[MAX_CHARS+1]; + int numchars; + + numchars = MIN (nc, MAX_CHARS); + strncpy (cname, name, numchars); + cname[numchars] = '\0'; + return GPTLquerycounters (cname, *t, papicounters_out); +} + +int gptlget_wallclock (const char *name, int *t, double *value, int nc) +{ + char cname[MAX_CHARS+1]; + int numchars; + + numchars = MIN (nc, MAX_CHARS); + strncpy (cname, name, numchars); + cname[numchars] = '\0'; + + return GPTLget_wallclock (cname, *t, value); +} + +int gptlget_eventvalue (const char *timername, const char *eventname, int *t, double *value, + int nc1, int nc2) +{ + char ctimername[MAX_CHARS+1]; + char ceventname[MAX_CHARS+1]; + int numchars; + + numchars = MIN (nc1, MAX_CHARS); + strncpy (ctimername, timername, numchars); + ctimername[numchars] = '\0'; + + numchars = MIN (nc2, MAX_CHARS); + strncpy (ceventname, eventname, numchars); + ceventname[numchars] = '\0'; + + return GPTLget_eventvalue (ctimername, ceventname, *t, value); +} + +int gptlget_nregions (int *t, int *nregions) +{ + return GPTLget_nregions (*t, nregions); +} + +int gptlget_regionname (int *t, int *region, char *name, int nc) +{ + int n; + int ret; + + ret = GPTLget_regionname (*t, *region, name, nc); + /* Turn nulls into spaces for fortran */ + for (n = 0; n < nc; ++n) + if (name[n] == '\0') + name[n] = ' '; + return ret; +} + +int gptlget_memusage (int *size, int *rss, int *share, int *text, int *datastack) +{ + return GPTLget_memusage (size, rss, share, text, datastack); +} + +int gptlprint_memusage (const char *str, int nc) +{ + char cname[128+1]; + int numchars = MIN (nc, 128); + + strncpy (cname, str, numchars); + cname[numchars] = '\0'; + return GPTLprint_memusage (cname); +} + +#ifdef HAVE_PAPI +#include + +int gptl_papilibraryinit (void) +{ + return GPTL_PAPIlibraryinit (); +} + +int gptlevent_name_to_code (const char *str, int *code, int nc) +{ + char cname[PAPI_MAX_STR_LEN+1]; + int numchars = MIN (nc, PAPI_MAX_STR_LEN); + + strncpy (cname, str, numchars); + cname[numchars] = '\0'; + + /* "code" is an int* and is an output variable */ + + return GPTLevent_name_to_code (cname, code); +} + +int gptlevent_code_to_name (int *code, char *str, int nc) +{ + int i; + + if (nc < PAPI_MAX_STR_LEN) + return GPTLerror ("gptl_event_code_to_name: output name must hold at least %d characters\n", + PAPI_MAX_STR_LEN); + + if (GPTLevent_code_to_name (*code, str) == 0) { + for (i = strlen(str); i < nc; ++i) + str[i] = ' '; + } else { + return GPTLerror (""); + } + return 0; +} +#else + +int gptl_papilibraryinit (void) +{ + return GPTL_PAPIlibraryinit (); +} + +int gptlevent_name_to_code (const char *str, int *code, int nc) +{ + return GPTLevent_name_to_code (str, code); +} + +int gptlevent_code_to_name (const int *code, char *str, int nc) +{ + return GPTLevent_code_to_name (*code, str); +} + +#endif diff --git a/share/timing/gptl.c b/share/timing/gptl.c new file mode 100644 index 000000000000..fe65810bba80 --- /dev/null +++ b/share/timing/gptl.c @@ -0,0 +1,5149 @@ +/* +** $Id: gptl.c,v 1.157 2011-03-28 20:55:18 rosinski Exp $ +** +** Author: Jim Rosinski +** +** Main file contains most user-accessible GPTL functions +*/ + +#include /* malloc */ +#include /* gettimeofday */ +#include /* times */ +#include /* gettimeofday, syscall */ +#include +#include /* memset, strcmp (via STRMATCH), strncmp (via STRNMATCH) */ +#include /* isdigit */ +#include /* u_int8_t, u_int16_t */ +#include + +#ifndef HAVE_C99_INLINE +#define inline +#endif + +#ifdef HAVE_PAPI +#include /* PAPI_get_real_usec */ +#endif + +#ifdef HAVE_LIBRT +#include +#endif + +#ifdef _AIX +#include +#endif + +#include "private.h" +#include "gptl.h" + +static Timer **timers = 0; /* linked list of timers */ +static Timer **last = 0; /* last element in list */ +static int *max_depth; /* maximum indentation level encountered */ +static int *max_name_len; /* max length of timer name */ +static volatile int nthreads = -1; /* num threads. Init to bad value */ +static volatile int maxthreads = -1; /* max threads (=nthreads for OMP). Init to bad value */ +static int depthlimit = 99999; /* max depth for timers (99999 is effectively infinite) */ +static volatile bool disabled = false; /* Timers disabled? */ +static volatile bool initialized = false; /* GPTLinitialize has been called */ +static volatile bool pr_has_been_called = false; /* GPTLpr_file has been called */ +static Entry eventlist[MAX_AUX]; /* list of PAPI-based events to be counted */ +static int nevents = 0; /* number of PAPI events (init to 0) */ +static bool dousepapi = false; /* saves a function call if stays false */ +static bool verbose = false; /* output verbosity */ +static bool percent = false; /* print wallclock also as percent of 1st timers[0] */ +static bool dopr_preamble = true; /* whether to print preamble info */ +static bool dopr_threadsort = true; /* whether to print sorted thread stats */ +static bool dopr_multparent = true; /* whether to print multiple parent info */ +static bool dopr_collision = true; /* whether to print hash collision info */ +static bool pr_append = false; /* whether to append to output file */ + +static time_t ref_gettimeofday = -1; /* ref start point for gettimeofday */ +static time_t ref_clock_gettime = -1;/* ref start point for clock_gettime */ +#ifdef _AIX +static time_t ref_read_real_time = -1; /* ref start point for read_real_time */ +#endif +static long long ref_papitime = -1; /* ref start point for PAPI_get_real_usec */ + +#if ( defined THREADED_OMP ) + +#include +static volatile int *threadid_omp = 0; /* array of thread ids */ + +#elif ( defined THREADED_PTHREADS ) + +#include + +#define MUTEX_API +#ifdef MUTEX_API +static volatile pthread_mutex_t t_mutex; +#else +static volatile pthread_mutex_t t_mutex = PTHREAD_MUTEX_INITIALIZER; +#endif +static volatile pthread_t *threadid = 0; /* array of thread ids */ +static int lock_mutex (void); /* lock a mutex for entry into a critical region */ +static int unlock_mutex (void); /* unlock a mutex for exit from a critical region */ + +#else + +/* Unthreaded case */ +static int threadid = -1; + +#endif + +typedef struct { + const Option option; /* wall, cpu, etc. */ + const char *str; /* descriptive string for printing */ + bool enabled; /* flag */ +} Settings; + +/* For Summary stats */ + +typedef struct { + double wallmax; + double wallmin; + double walltotal; + int processes; + int threads; +#ifdef HAVE_PAPI + double papimax[MAX_AUX]; + double papimin[MAX_AUX]; + double papitotal[MAX_AUX]; +#endif + unsigned long count; + int wallmax_p; /* over processes */ + int wallmax_t; /* over threads */ + int wallmin_p; + int wallmin_t; +#ifdef HAVE_PAPI + int papimax_p[MAX_AUX]; /* over processes */ + int papimax_t[MAX_AUX]; /* over threads */ + int papimin_p[MAX_AUX]; + int papimin_t[MAX_AUX]; +#endif +} Summarystats; + +/* Options, print strings, and default enable flags */ + +static Settings cpustats = {GPTLcpu, "Usr sys usr+sys ", false}; +static Settings wallstats = {GPTLwall, " Wallclock max min", true }; +static Settings overheadstats = {GPTLoverhead, " UTR Overhead " , true }; +static Settings profileovhd = {GPTLprofile_ovhd, "", false }; + +static Hashentry **hashtable; /* table of entries */ +static long ticks_per_sec; /* clock ticks per second */ +static char **timerlist; /* list of all timers */ + +typedef struct { + int val; /* depth in calling tree */ + int padding[31]; /* padding is to mitigate false cache sharing */ +} Nofalse; +static Timer ***callstack; /* call stack */ +static Nofalse *stackidx; /* index into callstack: */ + +static Method method = GPTLmost_frequent; /* default parent/child printing mechanism */ + +/* Local function prototypes */ + +static void printstats (const Timer *, FILE *, const int, const int, const bool, double); +static void add (Timer *, const Timer *); + +static void get_threadstats (const int, const char *, Summarystats *); +static void get_summarystats (Summarystats *, const Summarystats *); +#ifdef HAVE_MPI +static int collect_data( const int, MPI_Comm, int *, Summarystats ** ); +#else +static int collect_data( const int, const int, int *, Summarystats ** ); +#endif +static int merge_thread_data(); + +static void print_multparentinfo (FILE *, Timer *); +static inline int get_cpustamp (long *, long *); +static int newchild (Timer *, Timer *); +static int get_max_depth (const Timer *, const int); +static int num_descendants (Timer *); +static int is_descendant (const Timer *, const Timer *); +static int show_descendant (const int, const Timer *, const Timer *); +static char *methodstr (Method); + +/* Prototypes from previously separate file threadutil.c */ + +static int threadinit (void); /* initialize threading environment */ +static void threadfinalize (void); /* finalize threading environment */ +static void print_threadmapping (FILE *); /* print mapping of thread ids */ +static inline int get_thread_num (void); /* get 0-based thread number */ + +/* These are the (possibly) supported underlying wallclock timers */ + +static inline double utr_nanotime (void); +static inline double utr_mpiwtime (void); +static inline double utr_clock_gettime (void); +static inline double utr_papitime (void); +static inline double utr_read_real_time (void); +static inline double utr_gettimeofday (void); + +static int init_nanotime (void); +static int init_mpiwtime (void); +static int init_clock_gettime (void); +static int init_papitime (void); +static int init_read_real_time (void); +static int init_gettimeofday (void); + +static double utr_getoverhead (void); +static inline Timer *getentry_instr (const Hashentry *, void *, unsigned int *); +static inline Timer *getentry (const Hashentry *, const char *, unsigned int *); +static inline Timer *getentryf (const Hashentry *, const char *, const int, unsigned int *); +static void printself_andchildren (const Timer *, FILE *, const int, const int, const double); +static inline int update_parent_info (Timer *, Timer **, int); +static inline int update_stats (Timer *, const double, const long, const long, const int); +static int update_ll_hash (Timer *, const int, const unsigned int); +static inline int update_ptr (Timer *, const int); +static int construct_tree (Timer *, Method); + +static int cmp (const void *, const void *); +static int ncmp (const void *, const void *); +static int get_index ( const char *, const char *); + +typedef struct { + const Funcoption option; + double (*func)(void); + int (*funcinit)(void); + const char *name; +} Funcentry; + +static Funcentry funclist[] = { + {GPTLgettimeofday, utr_gettimeofday, init_gettimeofday, "gettimeofday"}, + {GPTLnanotime, utr_nanotime, init_nanotime, "nanotime"}, + {GPTLmpiwtime, utr_mpiwtime, init_mpiwtime, "MPI_Wtime"}, + {GPTLclockgettime, utr_clock_gettime, init_clock_gettime, "clock_gettime"}, + {GPTLpapitime, utr_papitime, init_papitime, "PAPI_get_real_usec"}, + {GPTLread_real_time, utr_read_real_time, init_read_real_time,"read_real_time"} /* AIX only */ +}; +static const int nfuncentries = sizeof (funclist) / sizeof (Funcentry); + +static double (*ptr2wtimefunc)() = 0; /* init to invalid */ +static int funcidx = 0; /* default timer is gettimeofday */ + +#ifdef HAVE_NANOTIME +static float cpumhz = -1.; /* init to bad value */ +static double cyc2sec = -1; /* init to bad value */ +static unsigned inline long long nanotime (void); /* read counter (assembler) */ +static float get_clockfreq (void); /* cycles/sec */ +#endif + +#define DEFAULT_TABLE_SIZE 2048 +static int tablesize = DEFAULT_TABLE_SIZE; /* per-thread size of hash table (settable parameter) */ +static char *outdir = 0; /* dir to write output files to (currently unused) */ + +static double overhead_utr = 0.0; /* timer cost estimate */ +static double overhead_est = 0.0; /* direct measurement of overhead for thread 0 */ +static double overhead_bound = 0.0; /* direct measurement of overhead for thread 0 */ + +/* VERBOSE is a debugging ifdef local to the rest of this file */ +#undef VERBOSE + +/* +** GPTLsetoption: set option value to true or false. +** +** Input arguments: +** option: option to be set +** val: value to which option should be set (nonzero=true, zero=false) +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLsetoption (const int option, /* option */ + const int val) /* value */ +{ + static const char *thisfunc = "GPTLsetoption"; + + if (initialized) + return GPTLerror ("%s: must be called BEFORE GPTLinitialize\n", thisfunc); + + if (option == GPTLabort_on_error) { + GPTLset_abort_on_error ((bool) val); + if (verbose) + printf ("%s: boolean abort_on_error = %d\n", thisfunc, val); + return 0; + } + + switch (option) { + case GPTLcpu: +#ifdef HAVE_TIMES + cpustats.enabled = (bool) val; + if (verbose) + printf ("%s: cpustats = %d\n", thisfunc, val); +#else + if (val) + return GPTLerror ("%s: times() not available\n", thisfunc); +#endif + return 0; + case GPTLwall: + wallstats.enabled = (bool) val; + if (verbose) + printf ("%s: boolean wallstats = %d\n", thisfunc, val); + return 0; + case GPTLoverhead: + overheadstats.enabled = (bool) val; + if (verbose) + printf ("%s: boolean overheadstats = %d\n", thisfunc, val); + return 0; + case GPTLprofile_ovhd: + profileovhd.enabled = (bool) val; + if (verbose) + printf ("%s: boolean profileovhd = %d\n", thisfunc, val); + return 0; + case GPTLdepthlimit: + depthlimit = val; + if (verbose) + printf ("%s: depthlimit = %d\n", thisfunc, val); + return 0; + case GPTLverbose: + verbose = (bool) val; +#ifdef HAVE_PAPI + (void) GPTL_PAPIsetoption (GPTLverbose, val); +#endif + if (verbose) + printf ("%s: boolean verbose = %d\n", thisfunc, val); + return 0; + case GPTLpercent: + percent = (bool) val; + if (verbose) + printf ("%s: boolean percent = %d\n", thisfunc, val); + return 0; + case GPTLdopr_preamble: + dopr_preamble = (bool) val; + if (verbose) + printf ("%s: boolean dopr_preamble = %d\n", thisfunc, val); + return 0; + case GPTLdopr_threadsort: + dopr_threadsort = (bool) val; + if (verbose) + printf ("%s: boolean dopr_threadsort = %d\n", thisfunc, val); + return 0; + case GPTLdopr_multparent: + dopr_multparent = (bool) val; + if (verbose) + printf ("%s: boolean dopr_multparent = %d\n", thisfunc, val); + return 0; + case GPTLdopr_collision: + dopr_collision = (bool) val; + if (verbose) + printf ("%s: boolean dopr_collision = %d\n", thisfunc, val); + return 0; + case GPTLprint_method: + method = (Method) val; + if (verbose) + printf ("%s: print_method = %s\n", thisfunc, methodstr (method)); + return 0; + case GPTLtablesize: + if (val < 1) + return GPTLerror ("%s: tablesize must be positive. %d is invalid\n", thisfunc, val); + + tablesize = val; + if (verbose) + printf ("%s: tablesize = %d\n", thisfunc, tablesize); + return 0; + case GPTLsync_mpi: +#ifdef ENABLE_PMPI + if (GPTLpmpi_setoption (option, val) != 0) + fprintf (stderr, "%s: GPTLpmpi_setoption failure\n", thisfunc); +#endif + if (verbose) + printf ("%s: boolean sync_mpi = %d\n", thisfunc, val); + return 0; + + /* + ** Allow GPTLmultiplex to fall through because it will be handled by + ** GPTL_PAPIsetoption() + */ + + case GPTLmultiplex: + default: + break; + } + +#ifdef HAVE_PAPI + if (GPTL_PAPIsetoption (option, val) == 0) { + if (val) + dousepapi = true; + return 0; + } +#else + /* Make GPTLnarrowprint a placebo if PAPI not enabled */ + + if (option == GPTLnarrowprint) + return 0; +#endif + + return GPTLerror ("%s: faiure to enable option %d\n", thisfunc, option); +} + +/* +** GPTLsetutr: set underlying timing routine. +** +** Input arguments: +** option: index which sets function +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLsetutr (const int option) +{ + int i; /* index over number of underlying timer */ + static const char *thisfunc = "GPTLsetutr"; + + if (initialized) + return GPTLerror ("%s: must be called BEFORE GPTLinitialize\n", thisfunc); + + for (i = 0; i < nfuncentries; i++) { + if (option == (int) funclist[i].option) { + if (verbose) + printf ("%s: underlying wallclock timer = %s\n", thisfunc, funclist[i].name); + funcidx = i; + + /* + ** Return an error condition if the function is not available. + ** OK for the user code to ignore: GPTLinitialize() will reset to gettimeofday + */ + + if ((*funclist[i].funcinit)() < 0) + return GPTLerror ("%s: utr=%s not available\n", thisfunc, funclist[i].name); + else + return 0; + } + } + return GPTLerror ("%s: unknown option %d\n", thisfunc, option); +} + +/* +** GPTLinitialize (): Initialization routine must be called from single-threaded +** region before any other timing routines may be called. The need for this +** routine could be eliminated if not targetting timing library for threaded +** capability. +** +** return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLinitialize (void) +{ + int i; /* loop index */ + int t; /* thread index */ + double t1, t2; /* returned from underlying timer */ + static const char *thisfunc = "GPTLinitialize"; + + if (initialized) + return GPTLerror ("%s: has already been called\n", thisfunc); + + if (threadinit () < 0) + return GPTLerror ("%s: bad return from threadinit\n", thisfunc); + + if ((ticks_per_sec = sysconf (_SC_CLK_TCK)) == -1) + return GPTLerror ("%s: failure from sysconf (_SC_CLK_TCK)\n", thisfunc); + + /* Allocate space for global arrays */ + + callstack = (Timer ***) GPTLallocate (maxthreads * sizeof (Timer **)); + stackidx = (Nofalse *) GPTLallocate (maxthreads * sizeof (Nofalse)); + timers = (Timer **) GPTLallocate (maxthreads * sizeof (Timer *)); + last = (Timer **) GPTLallocate (maxthreads * sizeof (Timer *)); + max_depth = (int *) GPTLallocate (maxthreads * sizeof (int)); + max_name_len = (int *) GPTLallocate (maxthreads * sizeof (int)); + hashtable = (Hashentry **) GPTLallocate (maxthreads * sizeof (Hashentry *)); + + /* Initialize array values */ + + for (t = 0; t < maxthreads; t++) { + max_depth[t] = -1; + max_name_len[t] = 0; + callstack[t] = (Timer **) GPTLallocate (MAX_STACK * sizeof (Timer *)); + hashtable[t] = (Hashentry *) GPTLallocate (tablesize * sizeof (Hashentry)); + for (i = 0; i < tablesize; i++) { + hashtable[t][i].nument = 0; + hashtable[t][i].entries = 0; + } + + /* + ** Make a timer "GPTL_ROOT" to ensure no orphans, and to simplify printing. + */ + + timers[t] = (Timer *) GPTLallocate (sizeof (Timer)); + memset (timers[t], 0, sizeof (Timer)); + strcpy (timers[t]->name, "GPTL_ROOT"); + timers[t]->onflg = true; + last[t] = timers[t]; + + stackidx[t].val = 0; + callstack[t][0] = timers[t]; + for (i = 1; i < MAX_STACK; i++) + callstack[t][i] = 0; + } + +#ifdef HAVE_PAPI + if (GPTL_PAPIinitialize (maxthreads, verbose, &nevents, eventlist) < 0) + return GPTLerror ("%s: Failure from GPTL_PAPIinitialize\n", thisfunc); +#endif + + /* + ** Call init routine for underlying timing routine. + */ + + if ((*funclist[funcidx].funcinit)() < 0) { + fprintf (stderr, "%s: Failure initializing %s. Reverting underlying timer to %s\n", + thisfunc, funclist[funcidx].name, funclist[0].name); + funcidx = 0; + } + + ptr2wtimefunc = funclist[funcidx].func; + + if (verbose) { + t1 = (*ptr2wtimefunc) (); + t2 = (*ptr2wtimefunc) (); + if (t1 > t2) + fprintf (stderr, "%s: negative delta-t=%g\n", thisfunc, t2-t1); + + printf ("Per call overhead est. t2-t1=%g should be near zero\n", t2-t1); + printf ("Underlying wallclock timing routine is %s\n", funclist[funcidx].name); + } + + /* set global timer overhead estimate */ + if (wallstats.enabled && profileovhd.enabled){ + overhead_utr = utr_getoverhead (); + } + + initialized = true; + return 0; +} + +/* +** GPTLfinalize (): Finalization routine must be called from single-threaded +** region. Free all malloc'd space +** +** return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLfinalize (void) +{ + int t; /* thread index */ + int n; /* array index */ + Timer *ptr, *ptrnext; /* ll indices */ + static const char *thisfunc = "GPTLfinalize"; + + if ( ! initialized) + return GPTLerror ("%s: initialization was not completed\n", thisfunc); + + for (t = 0; t < maxthreads; ++t) { + for (n = 0; n < tablesize; ++n) { + if (hashtable[t][n].nument > 0) + free (hashtable[t][n].entries); + } + free (hashtable[t]); + hashtable[t] = NULL; + free (callstack[t]); + for (ptr = timers[t]; ptr; ptr = ptrnext) { + ptrnext = ptr->next; + if (ptr->nparent > 0) { + free (ptr->parent); + free (ptr->parent_count); + } + if (ptr->nchildren > 0) + free (ptr->children); + free (ptr); + } + } + + free (callstack); + free (stackidx); + free (timers); + free (last); + free (max_depth); + free (max_name_len); + free (hashtable); + + threadfinalize (); + +#ifdef HAVE_PAPI + GPTL_PAPIfinalize (maxthreads); +#endif + + /* Reset initial values */ + + timers = 0; + last = 0; + max_depth = 0; + max_name_len = 0; + nthreads = -1; + maxthreads = -1; + depthlimit = 99999; + disabled = false; + initialized = false; + pr_has_been_called = false; + dousepapi = false; + verbose = false; + percent = false; + dopr_preamble = true; + dopr_threadsort = true; + dopr_multparent = true; + dopr_collision = true; + pr_append = false; + ref_gettimeofday = -1; + ref_clock_gettime = -1; +#ifdef _AIX + ref_read_real_time = -1; +#endif + ref_papitime = -1; + funcidx = 0; +#ifdef HAVE_NANOTIME + cpumhz= 0; + cyc2sec = -1; +#endif + outdir = 0; + tablesize = DEFAULT_TABLE_SIZE; + + return 0; +} + +/* +** GPTLstart_instr: start a timer (auto-instrumented) +** +** Input arguments: +** self: function address +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstart_instr (void *self) +{ + Timer *ptr; /* linked list pointer */ + int t; /* thread index (of this thread) */ + unsigned int indx; /* hash table index */ + static const char *thisfunc = "GPTLstart_instr"; + + if (disabled) + return 0; + + if ( ! initialized) + return GPTLerror ("%s self=%p: GPTLinitialize has not been called\n", thisfunc, self); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** increment and return + */ + + if (stackidx[t].val >= depthlimit) { + ++stackidx[t].val; + return 0; + } + + ptr = getentry_instr (hashtable[t], self, &indx); + + /* + ** Recursion => increment depth in recursion and return. We need to return + ** because we don't want to restart the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr && ptr->onflg) { + ++ptr->recurselvl; + return 0; + } + + /* + ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct + ** behavior when GPTLstop_instr decrements stackidx[t] unconditionally. + */ + + if (++stackidx[t].val > MAX_STACK-1) + return GPTLerror ("%s: stack too big\n", thisfunc); + + if ( ! ptr) { /* Add a new entry and initialize */ + ptr = (Timer *) GPTLallocate (sizeof (Timer)); + memset (ptr, 0, sizeof (Timer)); + + /* + ** Need to save the address string for later conversion back to a real + ** name by an offline tool. + */ + + snprintf (ptr->name, MAX_CHARS+1, "%lx", (unsigned long) self); + ptr->address = self; + + if (update_ll_hash (ptr, t, indx) != 0) + return GPTLerror ("%s: update_ll_hash error\n", thisfunc); + } + + if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) + return GPTLerror ("%s: update_parent_info error\n", thisfunc); + + if (update_ptr (ptr, t) != 0) + return GPTLerror ("%s: update_ptr error\n", thisfunc); + + return (0); +} + +/* +** GPTLstart: start a timer +** +** Input arguments: +** name: timer name +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstart (const char *name) /* timer name */ +{ + Timer *ptr; /* linked list pointer */ + int t; /* thread index (of this thread) */ + int numchars; /* number of characters to copy */ + unsigned int indx; /* hash table index */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstart"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, name); + } + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** increment and return + */ + + if (stackidx[t].val >= depthlimit) { + ++stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* first caliper timestamp */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** ptr will point to the requested timer in the current list, + ** or NULL if this is a new entry + */ + + ptr = getentry (hashtable[t], name, &indx); + + /* + ** Recursion => increment depth in recursion and return. We need to return + ** because we don't want to restart the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr && ptr->onflg) { + ++ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + return 0; + } + + /* + ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct + ** behavior when GPTLstop decrements stackidx[t] unconditionally. + */ + + if (++stackidx[t].val > MAX_STACK-1) + return GPTLerror ("%s: stack too big\n", thisfunc); + + if ( ! ptr) { /* Add a new entry and initialize */ + ptr = (Timer *) GPTLallocate (sizeof (Timer)); + memset (ptr, 0, sizeof (Timer)); + + numchars = MIN (strlen (name), MAX_CHARS); + strncpy (ptr->name, name, numchars); + ptr->name[numchars] = '\0'; + + if (update_ll_hash (ptr, t, indx) != 0) + return GPTLerror ("%s: update_ll_hash error\n", thisfunc); + } + + if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) + return GPTLerror ("%s: update_parent_info error\n", thisfunc); + + if (update_ptr (ptr, t) != 0) + return GPTLerror ("%s: update_ptr error\n", thisfunc); + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return (0); +} + +/* +** GPTLstart_handle: start a timer based on a handle +** +** Input arguments: +** name: timer name (required when on input, handle=0) +** handle: pointer to timer matching "name" +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstart_handle (const char *name, /* timer name */ + void **handle) /* handle (output if input value is 0) */ +{ + Timer *ptr; /* linked list pointer */ + int t; /* thread index (of this thread) */ + int numchars; /* number of characters to copy */ + unsigned int indx = (unsigned int) -1; /* hash table index: init to bad value */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstart_handle"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, name); + } + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** increment and return + */ + + if (stackidx[t].val >= depthlimit) { + ++stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* first caliper timestamp */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** If on input, handle references a non-zero value, assume it's a previously returned Timer* + ** passed in by the user. If zero, generate the hash entry and return it to the user. + */ + + if (*handle) { + ptr = (Timer *) *handle; + } else { + ptr = getentry (hashtable[t], name, &indx); + } + + /* + ** Recursion => increment depth in recursion and return. We need to return + ** because we don't want to restart the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr && ptr->onflg) { + ++ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return 0; + } + + /* + ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct + ** behavior when GPTLstop decrements stackidx[t] unconditionally. + */ + + if (++stackidx[t].val > MAX_STACK-1) + return GPTLerror ("%s: stack too big\n", thisfunc); + + if ( ! ptr) { /* Add a new entry and initialize */ + ptr = (Timer *) GPTLallocate (sizeof (Timer)); + memset (ptr, 0, sizeof (Timer)); + + numchars = MIN (strlen (name), MAX_CHARS); + strncpy (ptr->name, name, numchars); + ptr->name[numchars] = '\0'; + + if (update_ll_hash (ptr, t, indx) != 0) + return GPTLerror ("%s: update_ll_hash error\n", thisfunc); + } + + if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) + return GPTLerror ("%s: update_parent_info error\n", thisfunc); + + if (update_ptr (ptr, t) != 0) + return GPTLerror ("%s: update_ptr error\n", thisfunc); + + /* + ** If on input, *handle was 0, return the pointer to the timer for future input + */ + + if ( ! *handle) + *handle = (void *) ptr; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return (0); +} + +/* +** GPTLstartf: start a timer when the timer name may not be null terminated +** +** Input arguments: +** name: timer name +** namelen: number of characters in timer name +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstartf (const char *name, const int namelen) /* timer name and length */ +{ + Timer *ptr; /* linked list pointer */ + int t; /* thread index (of this thread) */ + int numchars; /* number of characters to copy */ + unsigned int indx; /* hash table index */ + char strname[MAX_CHARS+1]; /* null terminated version of name */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstartf"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw numchars = MIN (namelen, MAX_CHARS); + //pw strncpy (strname, name, numchars); + //pw strname[numchars] = '\0'; + //pw return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, strname); + } + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** increment and return + */ + + if (stackidx[t].val >= depthlimit) { + ++stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* first caliper timestamp */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** ptr will point to the requested timer in the current list, + ** or NULL if this is a new entry + */ + + ptr = getentryf (hashtable[t], name, namelen, &indx); + + /* + ** Recursion => increment depth in recursion and return. We need to return + ** because we don't want to restart the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr && ptr->onflg) { + ++ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return 0; + } + + /* + ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct + ** behavior when GPTLstop decrements stackidx[t] unconditionally. + */ + + if (++stackidx[t].val > MAX_STACK-1) + return GPTLerror ("%s: stack too big\n", thisfunc); + + if ( ! ptr) { /* Add a new entry and initialize */ + ptr = (Timer *) GPTLallocate (sizeof (Timer)); + memset (ptr, 0, sizeof (Timer)); + + numchars = MIN (namelen, MAX_CHARS); + strncpy (ptr->name, name, numchars); + ptr->name[numchars] = '\0'; + + if (update_ll_hash (ptr, t, indx) != 0) + return GPTLerror ("%s: update_ll_hash error\n", thisfunc); + } + + if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) + return GPTLerror ("%s: update_parent_info error\n", thisfunc); + + if (update_ptr (ptr, t) != 0) + return GPTLerror ("%s: update_ptr error\n", thisfunc); + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return (0); +} + +/* +** GPTLstartf_handle: start a timer based on a handle +** when the timer name may not be null terminated +** +** Input arguments: +** name: timer name (required when on input, handle=0) +** namelen: number of characters in timer name +** handle: pointer to timer matching "name" +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstartf_handle (const char *name, /* timer name */ + const int namelen, /* timer name length */ + void **handle) /* handle (output if input value is 0) */ +{ + Timer *ptr; /* linked list pointer */ + int t; /* thread index (of this thread) */ + int numchars; /* number of characters to copy */ + unsigned int indx = (unsigned int) -1; /* hash table index: init to bad value */ + char strname[MAX_CHARS+1]; /* null terminated version of name */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstartf_handle"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw numchars = MIN (namelen, MAX_CHARS); + //pw strncpy (strname, name, numchars); + //pw strname[numchars] = '\0'; + //pw return GPTLerror ("%s name=%s: GPTLinitialize has not been called\n", thisfunc, strname); + } + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** increment and return + */ + + if (stackidx[t].val >= depthlimit) { + ++stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* first caliper timestamp */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** If on input, handle references a non-zero value, assume it's a previously returned Timer* + ** passed in by the user. If zero, generate the hash entry and return it to the user. + */ + + if (*handle) { + ptr = (Timer *) *handle; + } else { + ptr = getentryf (hashtable[t], name, namelen, &indx); + } + + /* + ** Recursion => increment depth in recursion and return. We need to return + ** because we don't want to restart the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr && ptr->onflg) { + ++ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return 0; + } + + /* + ** Increment stackidx[t] unconditionally. This is necessary to ensure the correct + ** behavior when GPTLstop decrements stackidx[t] unconditionally. + */ + + if (++stackidx[t].val > MAX_STACK-1) + return GPTLerror ("%s: stack too big\n", thisfunc); + + if ( ! ptr) { /* Add a new entry and initialize */ + ptr = (Timer *) GPTLallocate (sizeof (Timer)); + memset (ptr, 0, sizeof (Timer)); + + numchars = MIN (namelen, MAX_CHARS); + strncpy (ptr->name, name, numchars); + ptr->name[numchars] = '\0'; + + if (update_ll_hash (ptr, t, indx) != 0) + return GPTLerror ("%s: update_ll_hash error\n", thisfunc); + } + + if (update_parent_info (ptr, callstack[t], stackidx[t].val) != 0) + return GPTLerror ("%s: update_parent_info error\n", thisfunc); + + if (update_ptr (ptr, t) != 0) + return GPTLerror ("%s: update_ptr error\n", thisfunc); + + /* + ** If on input, *handle was 0, return the pointer to the timer for future input + */ + + if ( ! *handle) + *handle = (void *) ptr; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tpa) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tpa) + 2*overhead_utr); + } + } + + return (0); +} + +/* +** update_ll_hash: Update linked list and hash table. +** Called by GPTLstart(f), GPTLstart_instr and GPTLstart(f)_handle +** +** Input arguments: +** ptr: pointer to timer +** t: thread index +** indx: hash index +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static int update_ll_hash (Timer *ptr, const int t, const unsigned int indx) +{ + int nchars; /* number of chars */ + int nument; /* number of entries */ + Timer **eptr; /* for realloc */ + + nchars = strlen (ptr->name); + if (nchars > max_name_len[t]) + max_name_len[t] = nchars; + + last[t]->next = ptr; + last[t] = ptr; + ++hashtable[t][indx].nument; + nument = hashtable[t][indx].nument; + + eptr = (Timer **) realloc (hashtable[t][indx].entries, nument * sizeof (Timer *)); + if ( ! eptr) + return GPTLerror ("update_ll_hash: realloc error\n"); + + hashtable[t][indx].entries = eptr; + hashtable[t][indx].entries[nument-1] = ptr; + + return 0; +} + +/* +** update_ptr: Update timer contents. +** Called by GPTLstart(f) and GPTLstart_instr and GPTLstart(f)_handle +** +** Input arguments: +** ptr: pointer to timer +** t: thread index +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static inline int update_ptr (Timer *ptr, const int t) +{ + double tp2; /* time stamp */ + + ptr->onflg = true; + + if (cpustats.enabled && get_cpustamp (&ptr->cpu.last_utime, &ptr->cpu.last_stime) < 0) + return GPTLerror ("update_ptr: get_cpustamp error"); + + if (wallstats.enabled) { + tp2 = (*ptr2wtimefunc) (); + ptr->wall.last = tp2; + } + +#ifdef HAVE_PAPI + if (dousepapi && GPTL_PAPIstart (t, &ptr->aux) < 0) + return GPTLerror ("update_ptr: error from GPTL_PAPIstart\n"); +#endif + return 0; +} + +/* +** update_parent_info: update info about parent, and in the parent about this child +** +** Arguments: +** ptr: pointer to timer +** callstackt: callstack for this thread +** stackidxt: stack index for this thread +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static inline int update_parent_info (Timer *ptr, + Timer **callstackt, + int stackidxt) +{ + int n; /* loop index through known parents */ + Timer *pptr; /* pointer to parent in callstack */ + Timer **pptrtmp; /* for realloc parent pointer array */ + int nparent; /* number of parents */ + int *parent_count; /* number of times parent invoked this child */ + static const char *thisfunc = "update_parent_info"; + + if ( ! ptr ) + return -1; + + if (stackidxt < 0) + return GPTLerror ("%s: called with negative stackidx\n", thisfunc); + + callstackt[stackidxt] = ptr; + + /* + ** If the region has no parent, bump its orphan count + ** (should never happen since "GPTL_ROOT" added). + */ + + if (stackidxt == 0) { + ++ptr->norphan; + return 0; + } + + pptr = callstackt[stackidxt-1]; + + /* If this parent occurred before, bump its count */ + + for (n = 0; n < ptr->nparent; ++n) { + if (ptr->parent[n] == pptr) { + ++ptr->parent_count[n]; + break; + } + } + + /* If this is a new parent, update info */ + + if (n == ptr->nparent) { + ++ptr->nparent; + nparent = ptr->nparent; + pptrtmp = (Timer **) realloc (ptr->parent, nparent * sizeof (Timer *)); + if ( ! pptrtmp) + return GPTLerror ("%s: realloc error pptrtmp nparent=%d\n", thisfunc, nparent); + + ptr->parent = pptrtmp; + ptr->parent[nparent-1] = pptr; + parent_count = (int *) realloc (ptr->parent_count, nparent * sizeof (int)); + if ( ! parent_count) + return GPTLerror ("%s: realloc error parent_count nparent=%d\n", thisfunc, nparent); + + ptr->parent_count = parent_count; + ptr->parent_count[nparent-1] = 1; + } + + return 0; +} + +/* +** GPTLstop_instr: stop a timer (auto-instrumented) +** +** Input arguments: +** self: function address +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstop_instr (void *self) +{ + double tp1 = 0.0; /* time stamp */ + Timer *ptr; /* linked list pointer */ + int t; /* thread number for this process */ + unsigned int indx; /* index into hash table */ + long usr = 0; /* user time (returned from get_cpustamp) */ + long sys = 0; /* system time (returned from get_cpustamp) */ + static const char *thisfunc = "GPTLstop_instr"; + + if (disabled) + return 0; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* Get the timestamp */ + + if (wallstats.enabled) { + tp1 = (*ptr2wtimefunc) (); + } + + if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) + return GPTLerror ("%s: bad return from get_cpustamp\n", thisfunc); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** decrement and return + */ + + if (stackidx[t].val > depthlimit) { + --stackidx[t].val; + return 0; + } + + ptr = getentry_instr (hashtable[t], self, &indx); + + if ( ! ptr) + return GPTLerror ("%s: timer for %p had not been started.\n", thisfunc, self); + + if ( ! ptr->onflg ) + return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); + + ++ptr->count; + + /* + ** Recursion => decrement depth in recursion and return. We need to return + ** because we don't want to stop the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr->recurselvl > 0) { + ++ptr->nrecurse; + --ptr->recurselvl; + return 0; + } + + if (update_stats (ptr, tp1, usr, sys, t) != 0) + return GPTLerror ("%s: error from update_stats\n", thisfunc); + + return 0; +} + +/* +** GPTLstop: stop a timer +** +** Input arguments: +** name: timer name +** +** Return value: 0 (success) or -1 (failure) +*/ + +int GPTLstop (const char *name) /* timer name */ +{ + double tp1 = 0.0; /* time stamp */ + Timer *ptr; /* linked list pointer */ + int t; /* thread number for this process */ + unsigned int indx; /* index into hash table */ + long usr = 0; /* user time (returned from get_cpustamp) */ + long sys = 0; /* system time (returned from get_cpustamp) */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstop"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + } + + /* Get the timestamp */ + + if (wallstats.enabled) { + tp1 = (*ptr2wtimefunc) (); + } + + if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) + return GPTLerror ("%s: get_cpustamp error", thisfunc); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** decrement and return + */ + + if (stackidx[t].val > depthlimit) { + --stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* dummy clock call, to capture earlier tp1 call */ + tpa = (*ptr2wtimefunc) (); + } + } + + if ( ! (ptr = getentry (hashtable[t], name, &indx))) + return GPTLerror ("%s thread %d: timer for %s had not been started.\n", thisfunc, t, name); + + if ( ! ptr->onflg ) + return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); + + ++ptr->count; + + /* + ** Recursion => decrement depth in recursion and return. We need to return + ** because we don't want to stop the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr->recurselvl > 0) { + ++ptr->nrecurse; + --ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; + } + + if (update_stats (ptr, tp1, usr, sys, t) != 0) + return GPTLerror ("%s: error from update_stats\n", thisfunc); + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; +} + +/* +** GPTLstop_handle: stop a timer based on a handle +** +** Input arguments: +** name: timer name (used only for diagnostics) +** handle: pointer to timer +** +** Return value: 0 (success) or -1 (failure) +*/ + +int GPTLstop_handle (const char *name, /* timer name */ + void **handle) /* handle (output if input value is 0) */ +{ + double tp1 = 0.0; /* time stamp */ + Timer *ptr; /* linked list pointer */ + int t; /* thread number for this process */ + unsigned int indx; /* index into hash table */ + long usr = 0; /* user time (returned from get_cpustamp) */ + long sys = 0; /* system time (returned from get_cpustamp) */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstop_handle"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + } + + /* Get the timestamp */ + + if (wallstats.enabled) { + tp1 = (*ptr2wtimefunc) (); + } + + if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) + return GPTLerror (0); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** decrement and return + */ + + if (stackidx[t].val > depthlimit) { + --stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* dummy clock call, to capture earlier tp1 call */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** If on input, handle references a non-zero value, assume it's a previously returned Timer* + ** passed in by the user. If zero, generate the hash entry and return it to the user. + */ + + if (*handle) { + ptr = (Timer *) *handle; + } else { + if ( ! (ptr = getentry (hashtable[t], name, &indx))) + return GPTLerror ("%s thread %d: timer for %s had not been started.\n", thisfunc, t, name); + } + + if ( ! ptr->onflg ) + return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); + + ++ptr->count; + + /* + ** Recursion => decrement depth in recursion and return. We need to return + ** because we don't want to stop the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr->recurselvl > 0) { + ++ptr->nrecurse; + --ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; + } + + if (update_stats (ptr, tp1, usr, sys, t) != 0) + return GPTLerror ("%s: error from update_stats\n", thisfunc); + + /* + ** If on input, *handle was 0, return the pointer to the timer for future input + */ + + if ( ! *handle) + *handle = (void *) ptr; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; +} + +/* +** GPTLstopf: stop a timer when the timer name may not be null terminated +** +** Input arguments: +** name: timer name +** namelen: number of characters in timer name +** +** Return value: 0 (success) or -1 (failure) +*/ + +int GPTLstopf (const char *name, const int namelen) /* timer name and length */ +{ + double tp1 = 0.0; /* time stamp */ + Timer *ptr; /* linked list pointer */ + int t; /* thread number for this process */ + unsigned int indx; /* index into hash table */ + long usr = 0; /* user time (returned from get_cpustamp) */ + long sys = 0; /* system time (returned from get_cpustamp) */ + int numchars; /* number of characters to copy */ + char strname[MAX_CHARS+1]; /* null terminated version of name */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstopf"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + } + + /* Get the timestamp */ + + if (wallstats.enabled) { + tp1 = (*ptr2wtimefunc) (); + } + + if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) + return GPTLerror ("%s: get_cpustamp error", thisfunc); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** decrement and return + */ + + if (stackidx[t].val > depthlimit) { + --stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* dummy clock call, to capture earlier tp1 call */ + tpa = (*ptr2wtimefunc) (); + } + } + + if ( ! (ptr = getentryf (hashtable[t], name, namelen, &indx))){ + numchars = MIN (namelen, MAX_CHARS); + strncpy (strname, name, numchars); + strname[numchars] = '\0'; + return GPTLerror ("%s thread %d: timer for %s had not been started.\n", thisfunc, t, strname); + } + + if ( ! ptr->onflg ) + return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); + + ++ptr->count; + + /* + ** Recursion => decrement depth in recursion and return. We need to return + ** because we don't want to stop the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr->recurselvl > 0) { + ++ptr->nrecurse; + --ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; + } + + if (update_stats (ptr, tp1, usr, sys, t) != 0) + return GPTLerror ("%s: error from update_stats\n", thisfunc); + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; +} + +/* +** GPTLstopf_handle: stop a timer based on a handle +** when the timer name may not be null terminated +** +** Input arguments: +** name: timer name (used only for diagnostics) +** namelen: number of characters in timer name +** handle: pointer to timer +** +** Return value: 0 (success) or -1 (failure) +*/ + +int GPTLstopf_handle (const char *name, /* timer name */ + const int namelen, /* timer name length */ + void **handle) /* handle (output if input value is 0) */ +{ + double tp1 = 0.0; /* time stamp */ + Timer *ptr; /* linked list pointer */ + int t; /* thread number for this process */ + unsigned int indx; /* index into hash table */ + long usr = 0; /* user time (returned from get_cpustamp) */ + long sys = 0; /* system time (returned from get_cpustamp) */ + int numchars; /* number of characters to copy */ + char strname[MAX_CHARS+1]; /* null terminated version of name */ + double tpa = 0.0; /* time stamp */ + double tpb = 0.0; /* time stamp */ + static const char *thisfunc = "GPTLstopf_handle"; + + if (disabled) + return 0; + + if ( ! initialized){ + //pw++ + return 0; + //pw-- + //pw return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + } + + /* Get the timestamp */ + + if (wallstats.enabled) { + tp1 = (*ptr2wtimefunc) (); + } + + if (cpustats.enabled && get_cpustamp (&usr, &sys) < 0) + return GPTLerror (0); + + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + + /* + ** If current depth exceeds a user-specified limit for print, just + ** decrement and return + */ + + if (stackidx[t].val > depthlimit) { + --stackidx[t].val; + return 0; + } + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* dummy clock call, to capture earlier tp1 call */ + tpa = (*ptr2wtimefunc) (); + } + } + + /* + ** If on input, handle references a non-zero value, assume it's a previously returned Timer* + ** passed in by the user. If zero, generate the hash entry and return it to the user. + */ + + if (*handle) { + ptr = (Timer *) *handle; + } else { + if ( ! (ptr = getentryf (hashtable[t], name, namelen, &indx))){ + numchars = MIN (namelen, MAX_CHARS); + strncpy (strname, name, numchars); + strname[numchars] = '\0'; + return GPTLerror ("%s thread %d: timer for %s had not been started.\n", thisfunc, t, strname); + } + } + + if ( ! ptr->onflg ) + return GPTLerror ("%s: timer %s was already off.\n", thisfunc, ptr->name); + + ++ptr->count; + + /* + ** Recursion => decrement depth in recursion and return. We need to return + ** because we don't want to stop the timer. We want the reported time for + ** the timer to reflect the outermost layer of recursion. + */ + + if (ptr->recurselvl > 0) { + ++ptr->nrecurse; + --ptr->recurselvl; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; + } + + if (update_stats (ptr, tp1, usr, sys, t) != 0) + return GPTLerror ("%s: error from update_stats\n", thisfunc); + + /* + ** If on input, *handle was 0, return the pointer to the timer for future input + */ + + if ( ! *handle) + *handle = (void *) ptr; + + if (wallstats.enabled && profileovhd.enabled){ + if (t == 0){ + /* second caliper timestamp */ + tpb = (*ptr2wtimefunc) (); + /* subtract out additional overhead from caliper timing calls */ + overhead_est += ((tpb - tp1) - overhead_utr); + /* add in additional overhead due to caliper timing calls (probaby 2X what necessary) */ + overhead_bound += ((tpb - tp1) + 2*overhead_utr); + } + } + + return 0; +} + +/* +** update_stats: update stats inside ptr. Called by GPTLstop(f), GPTLstop_instr, +** GPTLstop(f)_handle +** +** Input arguments: +** ptr: pointer to timer +** tp1: input time stapm +** usr: user time +** sys: system time +** t: thread index +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static inline int update_stats (Timer *ptr, + const double tp1, + const long usr, + const long sys, + const int t) +{ + double delta; /* difference */ + static const char *thisfunc = "update_stats"; + + ptr->onflg = false; + --stackidx[t].val; + if (stackidx[t].val < -1) { + stackidx[t].val = -1; + return GPTLerror ("%s: tree depth has become negative.\n", thisfunc); + } + +#ifdef HAVE_PAPI + if (dousepapi && GPTL_PAPIstop (t, &ptr->aux) < 0) + return GPTLerror ("%s: error from GPTL_PAPIstop\n", thisfunc); +#endif + + if (wallstats.enabled) { + delta = tp1 - ptr->wall.last; + ptr->wall.accum += delta; + + if (delta < 0.) { + fprintf (stderr, "%s: negative delta=%g\n", thisfunc, delta); + } + + if (ptr->count == 1) { + ptr->wall.max = delta; + ptr->wall.min = delta; + } else { + if (delta > ptr->wall.max) + ptr->wall.max = delta; + if (delta < ptr->wall.min) + ptr->wall.min = delta; + } + } + + if (cpustats.enabled) { + ptr->cpu.accum_utime += usr - ptr->cpu.last_utime; + ptr->cpu.accum_stime += sys - ptr->cpu.last_stime; + ptr->cpu.last_utime = usr; + ptr->cpu.last_stime = sys; + } + return 0; +} + +/* +** GPTLenable: enable timers +** +** Return value: 0 (success) +*/ + +int GPTLenable (void) +{ + disabled = false; + return (0); +} + +/* +** GPTLdisable: disable timers +** +** Return value: 0 (success) +*/ + +int GPTLdisable (void) +{ + disabled = true; + return (0); +} + +/* +** GPTLstamp: Compute timestamp of usr, sys, and wallclock time (seconds) +** +** Output arguments: +** wall: wallclock +** usr: user time +** sys: system time +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLstamp (double *wall, double *usr, double *sys) +{ + struct tms buf; /* argument to times */ + + if ( ! initialized) + return GPTLerror ("GPTLstamp: GPTLinitialize has not been called\n"); + +#ifdef HAVE_TIMES + *usr = 0; + *sys = 0; + + if (times (&buf) == -1) + return GPTLerror ("GPTLstamp: times() failed. Results bogus\n"); + + *usr = buf.tms_utime / (double) ticks_per_sec; + *sys = buf.tms_stime / (double) ticks_per_sec; +#endif + *wall = (*ptr2wtimefunc) (); + return 0; +} + +/* +** GPTLreset: reset all timers to 0 +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLreset (void) +{ + int t; /* index over threads */ + Timer *ptr; /* linked list index */ + static const char *thisfunc = "GPTLreset"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + for (t = 0; t < nthreads; t++) { + for (ptr = timers[t]; ptr; ptr = ptr->next) { + ptr->onflg = false; + ptr->count = 0; + memset (&ptr->wall, 0, sizeof (ptr->wall)); + memset (&ptr->cpu, 0, sizeof (ptr->cpu)); +#ifdef HAVE_PAPI + memset (&ptr->aux, 0, sizeof (ptr->aux)); +#endif + } + } + + if (verbose) + printf ("%s: accumulators for all timers set to zero\n", thisfunc); + + return 0; +} + +/* +** GPTLpr_set_append: set GPTLpr_file and GPTLpr_summary_file +** to use append mode +*/ + +int GPTLpr_set_append (void) +{ + pr_append = true; + return 0; +} + +/* +** GPTLpr_query_append: query whether GPTLpr_file and GPTLpr_summary_file +** use append mode +*/ + +int GPTLpr_query_append (void) +{ + if (pr_append) + return 1; + else + return 0; +} + +/* +** GPTLpr_set_write: set GPTLpr_file and GPTLpr_summary_file +** to use write mode +*/ + +int GPTLpr_set_write (void) +{ + pr_append = false; + return 0; +} + +/* +** GPTLpr_query_write: query whether GPTLpr_file and GPTLpr_summary_file +** use write mode +*/ + +int GPTLpr_query_write (void) +{ + if (pr_append) + return 0; + else + return 1; +} + +/* +** GPTLpr: Print values of all timers +** +** Input arguments: +** id: integer to append to string "timing." +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLpr (const int id) /* output file will be named "timing." */ +{ + char outfile[14]; /* name of output file: timing.xxxxxx */ + static const char *thisfunc = "GPTLpr"; + + if (id < 0 || id > 999999) + return GPTLerror ("%s: bad id=%d for output file. Must be >= 0 and < 1000000\n", thisfunc, id); + + sprintf (outfile, "timing.%d", id); + + if (GPTLpr_file (outfile) != 0) + return GPTLerror ("%s: Error in GPTLpr_file\n", thisfunc); + + return 0; +} + +/* +** GPTLpr_file: Print values of all timers +** +** Input arguments: +** outfile: Name of output file to write +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLpr_file (const char *outfile) /* output file to write */ +{ + FILE *fp; /* file handle to write to */ + Timer *ptr; /* walk through master thread linked list */ + Timer *tptr; /* walk through slave threads linked lists */ + Timer sumstats; /* sum of same timer stats over threads */ + int i, ii, n, t; /* indices */ + int totent; /* per-thread collision count (diagnostic) */ + int nument; /* per-index collision count (diagnostic) */ + int totlen; /* length for malloc */ + unsigned long totcount; /* total timer invocations */ + char *outpath; /* path to output file: outdir/timing.xxxxxx */ + float *sum; /* sum of overhead values (per thread) */ + float osum; /* sum of overhead over threads */ + double utr_overhead; /* overhead of calling underlying timing routine */ + double tot_overhead; /* utr_overhead + papi overhead */ + double papi_overhead = 0; /* overhead of reading papi counters */ + bool found; /* jump out of loop when name found */ + bool foundany; /* whether summation print necessary */ + bool first; /* flag 1st time entry found */ + /* + ** Diagnostics for collisions and GPTL memory usage + */ + int num_zero; /* number of buckets with 0 collisions */ + int num_one; /* number of buckets with 1 collision */ + int num_two; /* number of buckets with 2 collisions */ + int num_more; /* number of buckets with more than 2 collisions */ + int most; /* biggest collision count */ + int numtimers = 0; /* number of timers */ + float hashmem; /* hash table memory usage */ + float regionmem; /* timer memory usage */ + float papimem; /* PAPI stats memory usage */ + float pchmem; /* parent/child array memory usage */ + float gptlmem; /* total per-thread GPTL memory usage estimate */ + float totmem; /* sum of gptlmem across threads */ + + static const char *thisfunc = "GPTLpr_file"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize() has not been called\n", thisfunc); + + /* 2 is for "/" plus null */ + if (outdir) + totlen = strlen (outdir) + strlen (outfile) + 2; + else + totlen = strlen (outfile) + 2; + + outpath = (char *) GPTLallocate (totlen); + + if (outdir) { + strcpy (outpath, outdir); + strcat (outpath, "/"); + strcat (outpath, outfile); + } else { + strcpy (outpath, outfile); + } + + if (pr_append){ + if ( ! (fp = fopen (outpath, "a"))) + fp = stderr; + } + else{ + if ( ! (fp = fopen (outpath, "w"))) + fp = stderr; + } + + free (outpath); + + fprintf (fp, "$Id: gptl.c,v 1.157 2011-03-28 20:55:18 rosinski Exp $\n"); + + /* + ** A set of nasty ifdefs to tell important aspects of how GPTL was built + */ + +#ifdef HAVE_NANOTIME + if (funclist[funcidx].option == GPTLnanotime) { + fprintf (fp, "Clock rate = %f MHz\n", cpumhz); +#ifdef BIT64 + fprintf (fp, " BIT64 was true\n"); +#else + fprintf (fp, " BIT64 was false\n"); +#endif + } +#endif + +#if ( defined THREADED_OMP ) + fprintf (fp, "GPTL was built with THREADED_OMP\n"); +#elif ( defined THREADED_PTHREADS ) + fprintf (fp, "GPTL was built with THREADED_PTHREADS\n"); +#else + fprintf (fp, "GPTL was built without threading\n"); +#endif + +#ifdef HAVE_MPI + fprintf (fp, "HAVE_MPI was true\n"); + +#ifdef HAVE_COMM_F2C + fprintf (fp, " HAVE_COMM_F2C was true\n"); +#else + fprintf (fp, " HAVE_COMM_F2C was false\n"); +#endif + +#ifdef ENABLE_PMPI + fprintf (fp, " ENABLE_PMPI was true\n"); +#else + fprintf (fp, " ENABLE_PMPI was false\n"); +#endif + +#else + fprintf (fp, "HAVE_MPI was false\n"); +#endif + +#ifdef HAVE_PAPI + fprintf (fp, "HAVE_PAPI was true\n"); + if (dousepapi) { + if (GPTL_PAPIis_multiplexed ()) + fprintf (fp, " PAPI event multiplexing was ON\n"); + else + fprintf (fp, " PAPI event multiplexing was OFF\n"); + GPTL_PAPIprintenabled (fp); + } +#else + fprintf (fp, "HAVE_PAPI was false\n"); +#endif + + /* + ** Estimate underlying timing routine overhead + */ + + utr_overhead = utr_getoverhead (); + fprintf (fp, "Underlying timing routine was %s.\n", funclist[funcidx].name); + if (wallstats.enabled && profileovhd.enabled){ + fprintf (fp, "Per-call utr overhead est (at init): %g sec.\n", overhead_utr); + fprintf (fp, "Per-call utr overhead est (at end): %g sec.\n", utr_overhead); + }else{ + fprintf (fp, "Per-call utr overhead est: %g sec.\n", utr_overhead); + } +#ifdef HAVE_PAPI + if (dousepapi) { + double t1, t2; + t1 = (*ptr2wtimefunc) (); + read_counters100 (); + t2 = (*ptr2wtimefunc) (); + papi_overhead = 0.01 * (t2 - t1); + fprintf (fp, "Per-call PAPI overhead est: %g sec.\n", papi_overhead); + } +#endif + tot_overhead = utr_overhead + papi_overhead; + if (dopr_preamble) { + fprintf (fp, "If overhead stats are printed, roughly half the estimated number is\n" + "embedded in the wallclock stats for each timer.\n" + "Print method was %s.\n", methodstr (method)); +#ifdef ENABLE_PMPI + fprintf (fp, "If a AVG_MPI_BYTES field is present, it is an estimate of the per-call " + "average number of bytes handled by that process.\n" + "If timers beginning with sync_ are present, it means MPI synchronization " + "was turned on.\n"); +#endif + fprintf (fp, "If a \'%%_of\' field is present, it is w.r.t. the first timer for thread 0.\n" + "If a \'e6_per_sec\' field is present, it is in millions of PAPI counts per sec.\n\n" + "A '*' in column 1 below means the timer had multiple parents, though the\n" + "values printed are for all calls.\n" + "Further down the listing may be more detailed information about multiple\n" + "parents. Look for 'Multiple parent info'\n\n"); + } + + sum = (float *) GPTLallocate (nthreads * sizeof (float)); + + for (t = 0; t < nthreads; ++t) { + + /* + ** Construct tree for printing timers in parent/child form. get_max_depth() must be called + ** AFTER construct_tree() because it relies on the per-parent children arrays being complete. + */ + + if (construct_tree (timers[t], method) != 0) + printf ("GPTLpr_file: failure from construct_tree: output will be incomplete\n"); + max_depth[t] = get_max_depth (timers[t], 0); + + if (t > 0) + fprintf (fp, "\n"); + fprintf (fp, "Stats for thread %d:\n", t); + + for (n = 0; n < max_depth[t]+1; ++n) /* +1 to always indent timer name */ + fprintf (fp, " "); + for (n = 0; n < max_name_len[t]; ++n) /* longest timer name */ + fprintf (fp, " "); + + fprintf (fp, " On Called Recurse"); + + /* Print strings for enabled timer types */ + + if (cpustats.enabled) + fprintf (fp, "%s", cpustats.str); + if (wallstats.enabled) { + fprintf (fp, "%s", wallstats.str); + if (percent && timers[0]->next) + fprintf (fp, "%%_of_%5.5s ", timers[0]->next->name); + if (overheadstats.enabled) + fprintf (fp, "%s", overheadstats.str); + } + +#ifdef ENABLE_PMPI + fprintf (fp, "AVG_MPI_BYTES "); +#endif + +#ifdef HAVE_PAPI + GPTL_PAPIprstr (fp); +#endif + + fprintf (fp, "\n"); /* Done with titles, now print stats */ + + /* + ** Print call tree and stats via recursive routine. "-1" is flag to + ** avoid printing dummy outermost timer, and initialize the depth. + */ + + printself_andchildren (timers[t], fp, t, -1, tot_overhead); + + /* + ** Sum of overhead across timers is meaningful. + ** Factor of 2 is because there are 2 utr calls per start/stop pair. + */ + + sum[t] = 0; + totcount = 0; + for (ptr = timers[t]->next; ptr; ptr = ptr->next) { + sum[t] += ptr->count * 2 * tot_overhead; + totcount += ptr->count; + } + fprintf (fp, "\n"); + if (wallstats.enabled && overheadstats.enabled){ + fprintf (fp, "Overhead sum = %9.3g wallclock seconds\n", sum[t]); + } + if (t == 0){ + if (wallstats.enabled && profileovhd.enabled){ + fprintf (fp, "Overhead estimate = %9.3g wallclock seconds\n", overhead_est); + fprintf (fp, "Overhead bound = %9.3g wallclock seconds\n", overhead_bound); + } + } + if (totcount < PRTHRESH) + fprintf (fp, "Total calls = %lu\n", totcount); + else + fprintf (fp, "Total calls = %9.3e\n", (float) totcount); + } + + /* Print per-name stats for all threads */ + + if (dopr_threadsort && nthreads > 1) { + fprintf (fp, "\nSame stats sorted by timer for threaded regions (for timers active on thread 0):\n"); + fprintf (fp, "Thd "); + + for (n = 0; n < max_name_len[0]; ++n) /* longest timer name */ + fprintf (fp, " "); + + fprintf (fp, " On Called Recurse"); + + if (cpustats.enabled) + fprintf (fp, "%s", cpustats.str); + if (wallstats.enabled) { + fprintf (fp, "%s", wallstats.str); + if (percent && timers[0]->next) + fprintf (fp, "%%_of_%5.5s ", timers[0]->next->name); + if (overheadstats.enabled) + fprintf (fp, "%s", overheadstats.str); + } + +#ifdef HAVE_PAPI + GPTL_PAPIprstr (fp); +#endif + + fprintf (fp, "\n"); + + /* Start at next to skip dummy */ + + for (ptr = timers[0]->next; ptr; ptr = ptr->next) { + + /* + ** To print sum stats, first create a new timer then copy thread 0 + ** stats into it. then sum using "add", and finally print. + */ + + foundany = false; + first = true; + sumstats = *ptr; + for (t = 1; t < nthreads; ++t) { + found = false; + for (tptr = timers[t]->next; tptr && ! found; tptr = tptr->next) { + if (STRMATCH (ptr->name, tptr->name)) { + + /* Only print thread 0 when this timer found for other threads */ + + if (first) { + first = false; + fprintf (fp, "%3.3d ", 0); + printstats (ptr, fp, 0, 0, false, tot_overhead); + } + + found = true; + foundany = true; + fprintf (fp, "%3.3d ", t); + printstats (tptr, fp, 0, 0, false, tot_overhead); + add (&sumstats, tptr); + } + } + } + + if (foundany) { + fprintf (fp, "SUM "); + printstats (&sumstats, fp, 0, 0, false, tot_overhead); + fprintf (fp, "\n"); + } + } + + /* Repeat overhead print in loop over threads */ + + if (wallstats.enabled && overheadstats.enabled) { + osum = 0.; + for (t = 0; t < nthreads; ++t) { + fprintf (fp, "OVERHEAD.%3.3d (wallclock seconds) = %9.3g\n", t, sum[t]); + osum += sum[t]; + } + fprintf (fp, "OVERHEAD.SUM (wallclock seconds) = %9.3g\n", osum); + } + } + + /* Print info about timers with multiple parents */ + + if (dopr_multparent) { + for (t = 0; t < nthreads; ++t) { + bool some_multparents = false; /* thread has entries with multiple parents? */ + for (ptr = timers[t]->next; ptr; ptr = ptr->next) { + if (ptr->nparent > 1) { + some_multparents = true; + break; + } + } + + if (some_multparents) { + fprintf (fp, "\nMultiple parent info for thread %d:\n", t); + if (dopr_preamble && t == 0) { + fprintf (fp, "Columns are count and name for the listed child\n" + "Rows are each parent, with their common child being the last entry, " + "which is indented.\n" + "Count next to each parent is the number of times it called the child.\n" + "Count next to child is total number of times it was called by the " + "listed parents.\n\n"); + } + + for (ptr = timers[t]->next; ptr; ptr = ptr->next) + if (ptr->nparent > 1) + print_multparentinfo (fp, ptr); + } + } + } + + /* Print hash table stats */ + + if (dopr_collision) { + for (t = 0; t < nthreads; t++) { + first = true; + totent = 0; + num_zero = 0; + num_one = 0; + num_two = 0; + num_more = 0; + most = 0; + numtimers= 0; + + for (i = 0; i < tablesize; i++) { + nument = hashtable[t][i].nument; + if (nument > 1) { + totent += nument-1; + if (first) { + first = false; + fprintf (fp, "\nthread %d had some hash collisions:\n", t); + } + fprintf (fp, "hashtable[%d][%d] had %d entries:", t, i, nument); + for (ii = 0; ii < nument; ii++) + fprintf (fp, " %s", hashtable[t][i].entries[ii]->name); + fprintf (fp, "\n"); + } + switch (nument) { + case 0: + ++num_zero; + break; + case 1: + ++num_one; + break; + case 2: + ++num_two; + break; + default: + ++num_more; + break; + } + most = MAX (most, nument); + numtimers += nument; + } + + if (totent > 0) { + fprintf (fp, "Total collisions thread %d = %d\n", t, totent); + fprintf (fp, "Entry information:\n"); + fprintf (fp, "num_zero = %d num_one = %d num_two = %d num_more = %d\n", + num_zero, num_one, num_two, num_more); + fprintf (fp, "Most = %d\n", most); + } + } + } + + /* Stats on GPTL memory usage */ + + totmem = 0.; + for (t = 0; t < nthreads; t++) { + hashmem = (float) sizeof (Hashentry) * tablesize; + regionmem = (float) numtimers * sizeof (Timer); +#ifdef HAVE_PAPI + papimem = (float) numtimers * sizeof (Papistats); +#else + papimem = 0.; +#endif + pchmem = 0.; + for (ptr = timers[t]->next; ptr; ptr = ptr->next) + pchmem += (float) (sizeof (Timer *)) * (ptr->nchildren + ptr->nparent); + + gptlmem = hashmem + regionmem + pchmem; + totmem += gptlmem; + fprintf (fp, "\n"); + fprintf (fp, "Thread %d total memory usage = %g KB\n", t, gptlmem*.001); + fprintf (fp, " Hashmem = %g KB\n" + " Regionmem = %g KB (papimem portion = %g KB)\n" + " Parent/child arrays = %g KB\n", + hashmem*.001, regionmem*.001, papimem*.001, pchmem*.001); + } + fprintf (fp, "\n"); + fprintf (fp, "Total memory usage all threads = %g KB\n", totmem*0.001); + + print_threadmapping (fp); + free (sum); + + if (fclose (fp) != 0) + fprintf (stderr, "Attempt to close %s failed\n", outfile); + + pr_has_been_called = true; + return 0; +} + +/* +** construct_tree: Build the parent->children tree starting with knowledge of +** parent list for each child. +** +** Input arguments: +** timerst: Linked list of timers +** method: method to be used to define the links +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int construct_tree (Timer *timerst, Method method) +{ + Timer *ptr; /* loop through linked list */ + Timer *pptr = 0; /* parent (init to NULL to avoid compiler warning) */ + int nparent; /* number of parents */ + int maxcount; /* max calls by a single parent */ + int n; /* loop over nparent */ + + /* + ** Walk the linked list to build the parent-child tree, using whichever + ** mechanism is in place. newchild() will prevent loops. + */ + + for (ptr = timerst; ptr; ptr = ptr->next) { + switch (method) { + case GPTLfirst_parent: + if (ptr->nparent > 0) { + pptr = ptr->parent[0]; + if (newchild (pptr, ptr) != 0); + } + break; + case GPTLlast_parent: + if (ptr->nparent > 0) { + nparent = ptr->nparent; + pptr = ptr->parent[nparent-1]; + if (newchild (pptr, ptr) != 0); + } + break; + case GPTLmost_frequent: + maxcount = 0; + for (n = 0; n < ptr->nparent; ++n) { + if (ptr->parent_count[n] > maxcount) { + pptr = ptr->parent[n]; + maxcount = ptr->parent_count[n]; + } + } + if (maxcount > 0) { /* not an orphan */ + if (newchild (pptr, ptr) != 0); + } + break; + case GPTLfull_tree: + /* + ** Careful: this one can create *lots* of output! + */ + for (n = 0; n < ptr->nparent; ++n) { + pptr = ptr->parent[n]; + if (newchild (pptr, ptr) != 0); + } + break; + default: + return GPTLerror ("construct_tree: method %d is not known\n", method); + } + } + return 0; +} + +/* +** methodstr: Return a pointer to a string which represents the method +** +** Input arguments: +** method: method type +*/ + +static char *methodstr (Method method) +{ + if (method == GPTLfirst_parent) + return "first_parent"; + else if (method == GPTLlast_parent) + return "last_parent"; + else if (method == GPTLmost_frequent) + return "most_frequent"; + else if (method == GPTLfull_tree) + return "full_tree"; + else + return "Unknown"; +} + +/* +** newchild: Add an entry to the children list of parent. Use function +** is_descendant() to prevent infinite loops. +** +** Input arguments: +** parent: parent node +** child: child to be added +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static int newchild (Timer *parent, Timer *child) +{ + int nchildren; /* number of children (temporary) */ + Timer **chptr; /* array of pointers to children */ + int n; /* loop over nchildren */ + + static const char *thisfunc = "newchild"; + + if (parent == child) + return GPTLerror ("%s: child %s can't be a parent of itself\n", thisfunc, child->name); + + /* + ** To allow construct_tree to be called multiple times, check that proposed child + ** is not a known child + */ + + for (n = 0; n < parent->nchildren; ++n) { + if (parent->children[n] == child){ + n = parent->nchildren + 1; + } + } + if (n > parent->nchildren){ + return 0; + } + + /* + ** To guarantee no loops, ensure that proposed parent isn't already a descendant of + ** proposed child + */ + + if (is_descendant (child, parent)) { + show_descendant (0, child, parent); + return GPTLerror ("%s: loop detected: NOT adding %s to descendant list of %s. " + "Proposed parent is in child's descendant path.\n", + thisfunc, child->name, parent->name); + } + + /* Safe to add the child to the parent's list of children */ + + ++parent->nchildren; + nchildren = parent->nchildren; + chptr = (Timer **) realloc (parent->children, nchildren * sizeof (Timer *)); + if ( ! chptr) + return GPTLerror ("%s: realloc error\n", thisfunc); + parent->children = chptr; + parent->children[nchildren-1] = child; + + return 0; +} + +/* +** get_max_depth: Determine the maximum call tree depth by traversing the +** tree recursively +** +** Input arguments: +** ptr: Starting timer +** startdepth: current depth when function invoked +** +** Return value: maximum depth +*/ + +static int get_max_depth (const Timer *ptr, const int startdepth) +{ + int maxdepth = startdepth; + int depth; + int n; + + for (n = 0; n < ptr->nchildren; ++n) + if ((depth = get_max_depth (ptr->children[n], startdepth+1)) > maxdepth) + maxdepth = depth; + + return maxdepth; +} + +/* +** num_descendants: Determine the number of descendants of a timer by traversing +** the tree recursively. This function is not currently used. It could be +** useful in a pruning algorithm +** +** Input arguments: +** ptr: Starting timer +** +** Return value: number of descendants +*/ + +static int num_descendants (Timer *ptr) +{ + int n; + + ptr->num_desc = ptr->nchildren; + for (n = 0; n < ptr->nchildren; ++n) { + ptr->num_desc += num_descendants (ptr->children[n]); + } + return ptr->num_desc; +} + +/* +** is_descendant: Determine whether node2 is in the descendant list for +** node1 +** +** Input arguments: +** node1: starting node for recursive search +** node2: node to be searched for +** +** Return value: true or false +*/ + +static int is_descendant (const Timer *node1, const Timer *node2) +{ + int n; + + /* Breadth before depth for efficiency */ + + for (n = 0; n < node1->nchildren; ++n) + if (node1->children[n] == node2) + return 1; + + for (n = 0; n < node1->nchildren; ++n) + if (is_descendant (node1->children[n], node2)) + return 1; + + return 0; +} + +/* +** show_descendant: list descendants, breadth first, stopping early +** if a particular node is discovered (e.g. the parent) +** +** Input arguments: +** level: current level in recursion, should be 0 when first called +** node1: starting node for recursive listing +** node2: node defining the early stopping criterion +** +** Return value: true (listed all descendants) or false (stopped early) +*/ + +static int show_descendant (const int level, const Timer *node1, const Timer *node2) +{ + int n; + + /* Breadth before depth for efficiency */ + + for (n = 0; n < node1->nchildren; ++n){ + printf ("node1: %-32s level: %d child: %d label: %-32s\n", node1->name, level, n, node1->children[n]->name); + if (node1->children[n] == node2) + return 1; + } + + for (n = 0; n < node1->nchildren; ++n) + if (show_descendant (level+1, node1->children[n], node2)) + return 1; + + return 0; +} + +/* +** printstats: print a single timer +** +** Input arguments: +** timer: timer for which to print stats +** fp: file descriptor to write to +** t: thread number +** depth: depth to indent timer +** doindent: whether indenting will be done +** tot_overhead: underlying timing routine overhead +*/ + +static void printstats (const Timer *timer, + FILE *fp, + const int t, + const int depth, + const bool doindent, + const double tot_overhead) +{ + int i; /* index */ + int indent; /* index for indenting */ + int extraspace; /* for padding to length of longest name */ + float fusr; /* user time as float */ + float fsys; /* system time as float */ + float usrsys; /* usr + sys */ + float elapse; /* elapsed time */ + float wallmax; /* max wall time */ + float wallmin; /* min wall time */ + float ratio; /* percentage calc */ + + /* Flag regions having multiple parents with a "*" in column 1 */ + + if (doindent) { + if (timer->nparent > 1) + fprintf (fp, "* "); + else + fprintf (fp, " "); + + /* Indent to depth of this timer */ + + for (indent = 0; indent < depth; ++indent) + fprintf (fp, " "); + } + + fprintf (fp, "%s", timer->name); + + /* Pad to length of longest name */ + + extraspace = max_name_len[t] - strlen (timer->name); + for (i = 0; i < extraspace; ++i) + fprintf (fp, " "); + + /* Pad to max indent level */ + + if (doindent) + for (indent = depth; indent < max_depth[t]; ++indent) + fprintf (fp, " "); + + if (timer->onflg) + fprintf (fp, " y "); + else + fprintf (fp, " - "); + + if (timer->count < PRTHRESH) { + if (timer->nrecurse > 0) + fprintf (fp, "%8lu %6lu ", timer->count, timer->nrecurse); + else + fprintf (fp, "%8lu - ", timer->count); + } else { + if (timer->nrecurse > 0) + fprintf (fp, "%8.1e %6.0e ", (float) timer->count, (float) timer->nrecurse); + else + fprintf (fp, "%8.1e - ", (float) timer->count); + } + + if (cpustats.enabled) { + fusr = timer->cpu.accum_utime / (float) ticks_per_sec; + fsys = timer->cpu.accum_stime / (float) ticks_per_sec; + usrsys = fusr + fsys; + fprintf (fp, "%9.3f %9.3f %9.3f ", fusr, fsys, usrsys); + } + + if (wallstats.enabled) { + elapse = timer->wall.accum; + wallmax = timer->wall.max; + wallmin = timer->wall.min; + fprintf (fp, "%12.6f %12.6f %12.6f ", elapse, wallmax, wallmin); + + if (percent && timers[0]->next) { + ratio = 0.; + if (timers[0]->next->wall.accum > 0.) + ratio = (timer->wall.accum * 100.) / timers[0]->next->wall.accum; + fprintf (fp, " %9.2f ", ratio); + } + + /* + ** Factor of 2 is because there are 2 utr calls per start/stop pair. + */ + + if (overheadstats.enabled) { + fprintf (fp, "%16.6f ", timer->count * 2 * tot_overhead); + } + } + +#ifdef ENABLE_PMPI + if (timer->nbytes == 0.) + fprintf (fp, " - "); + else + fprintf (fp, "%13.3e ", timer->nbytes / timer->count); +#endif + +#ifdef HAVE_PAPI + GPTL_PAPIpr (fp, &timer->aux, t, timer->count, timer->wall.accum); +#endif + + fprintf (fp, "\n"); +} + +/* +** print_multparentinfo: +** +** Input arguments: +** Input/output arguments: +*/ +void print_multparentinfo (FILE *fp, + Timer *ptr) +{ + int n; + + if (ptr->norphan > 0) { + if (ptr->norphan < PRTHRESH) + fprintf (fp, "%8u %-32s\n", ptr->norphan, "ORPHAN"); + else + fprintf (fp, "%8.1e %-32s\n", (float) ptr->norphan, "ORPHAN"); + } + + for (n = 0; n < ptr->nparent; ++n) { + if (ptr->parent_count[n] < PRTHRESH) + fprintf (fp, "%8d %-32s\n", ptr->parent_count[n], ptr->parent[n]->name); + else + fprintf (fp, "%8.1e %-32s\n", (float) ptr->parent_count[n], ptr->parent[n]->name); + } + + if (ptr->count < PRTHRESH) + fprintf (fp, "%8lu %-32s\n\n", ptr->count, ptr->name); + else + fprintf (fp, "%8.1e %-32s\n\n", (float) ptr->count, ptr->name); +} + +/* +** add: add the contents of tin to tout +** +** Input arguments: +** tin: input timer +** Input/output arguments: +** tout: output timer summed into +*/ + +static void add (Timer *tout, + const Timer *tin) +{ + tout->count += tin->count; + + if (wallstats.enabled) { + tout->wall.accum += tin->wall.accum; + + tout->wall.max = MAX (tout->wall.max, tin->wall.max); + tout->wall.min = MIN (tout->wall.min, tin->wall.min); + } + + if (cpustats.enabled) { + tout->cpu.accum_utime += tin->cpu.accum_utime; + tout->cpu.accum_stime += tin->cpu.accum_stime; + } +#ifdef HAVE_PAPI + GPTL_PAPIadd (&tout->aux, &tin->aux); +#endif +} + +/* +** GPTLpr_summary: Gather and print summary stats across +** threads and MPI tasks +** +** Input arguments: +** comm: commuicator (e.g. MPI_COMM_WORLD). If zero, use MPI_COMM_WORLD +*/ + +#ifdef HAVE_MPI +int GPTLpr_summary (MPI_Comm comm) +#else +int GPTLpr_summary (int comm) +#endif +{ + const char *outfile = "timing.summary"; + int ret; + + ret = GPTLpr_summary_file(comm, outfile); + return 0; +} + +#ifdef HAVE_MPI +int GPTLpr_summary_file (MPI_Comm comm, + const char *outfile) +#else +int GPTLpr_summary_file (int comm, + const char *outfile) +#endif +{ + int iam = 0; /* MPI rank: default master */ + int n; /* index */ + int extraspace; /* for padding to length of longest name */ + int totlen; /* length for malloc */ + char *outpath; /* path to output file: outdir/outfile */ + FILE *fp = 0; /* output file */ + + int count; /* number of timers */ + Summarystats *storage; /* storage for data from all timers */ + + int x; /* pointer increment */ + int k; /* counter */ + char *tempname; /* event name workspace */ + int max_name_length; + int len; + float temp; + int ret; /* return code */ + + static const char *thisfunc = "GPTLpr_summary_file"; + +#ifdef HAVE_MPI + int nproc; /* number of procs in MPI communicator */ + + char name[MAX_CHARS+1]; /* timer name requested by master */ + + if (((int) comm) == 0) + comm = MPI_COMM_WORLD; + + if ((ret = MPI_Comm_rank (comm, &iam)) != MPI_SUCCESS) + return GPTLerror ("%s: Bad return from MPI_Comm_rank=%d\n", thisfunc, ret); + + if ((ret = MPI_Comm_size (comm, &nproc)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Comm_size=%d\n", thisfunc, iam, ret); + +#endif + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize() has not been called\n", thisfunc); + + /* + ** Each process gathers stats for its threads. + ** Binary tree used combine results. + ** Master prints results. + */ + + if (iam == 0) { + + /* 2 is for "/" plus null */ + if (outdir) + totlen = strlen (outdir) + strlen (outfile) + 2; + else + totlen = strlen (outfile) + 2; + + outpath = (char *) GPTLallocate (totlen); + + if (outdir) { + strcpy (outpath, outdir); + strcat (outpath, "/"); + strcat (outpath, outfile); + } else { + strcpy (outpath, outfile); + } + + if (pr_append){ + if ( ! (fp = fopen (outpath, "a"))) + fp = stderr; + } + else{ + if ( ! (fp = fopen (outpath, "w"))) + fp = stderr; + } + + free (outpath); + + fprintf (fp, "$Id: gptl.c,v 1.157 2011-03-28 20:55:18 rosinski Exp $\n"); + fprintf (fp, "'count' is cumulative. All other stats are max/min\n"); +#ifndef HAVE_MPI + fprintf (fp, "NOTE: GPTL was built WITHOUT MPI: Only task 0 stats will be printed.\n"); + fprintf (fp, "This is even for MPI codes.\n"); +#endif + + count = merge_thread_data(); /*merges events from all threads*/ + + if( !( tempname = (char*)malloc((MAX_CHARS + 1) * sizeof(char) ) ) ) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + /* allocate storage for data for all timers */ + if( !( storage = malloc( sizeof(Summarystats) * count ) ) && count ) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + if ( (ret = collect_data( iam, comm, &count, &storage) ) != 0 ) + return GPTLerror ("%s: master collect_data failed\n", thisfunc); + + x = 0; /*finds max timer name length*/ + max_name_length = 0; + for( k = 0; k < count; k++ ) { + len = strlen( timerlist[0] + x ); + if( len > max_name_length ) + max_name_length = len; + x += MAX_CHARS + 1; + } + + /* Print heading */ + + fprintf (fp, "name"); + extraspace = max_name_length - strlen ("name"); + for (n = 0; n < extraspace; ++n) + fprintf (fp, " "); + fprintf (fp, " processes threads count"); + fprintf (fp, " walltotal wallmax (proc thrd ) wallmin (proc thrd )"); + + for (n = 0; n < nevents; ++n) { + fprintf (fp, " %8.8stotal", eventlist[n].str8); + fprintf (fp, " %8.8smax (proc thrd )", eventlist[n].str8); + fprintf (fp, " %8.8smin (proc thrd )", eventlist[n].str8); + } + + fprintf (fp, "\n"); + + x = 0; + for( k = 0; k < count; k++ ) { + + /* Print the results for this timer */ + memset( tempname, 0, (MAX_CHARS + 1) * sizeof(char) ); + memcpy( tempname, timerlist[0] + x, (MAX_CHARS + 1) * sizeof(char) ); + + x += (MAX_CHARS + 1); + fprintf (fp, "%s", tempname); + extraspace = max_name_length - strlen (tempname); + for (n = 0; n < extraspace; ++n) + fprintf (fp, " "); + temp = storage[k].count; + fprintf(fp, " %8d %8d %12.6e ", + storage[k].processes, storage[k].threads, temp); + fprintf (fp, " %12.6e %9.3f (%6d %6d) %9.3f (%6d %6d)", + storage[k].walltotal, + storage[k].wallmax, storage[k].wallmax_p, storage[k].wallmax_t, + storage[k].wallmin, storage[k].wallmin_p, storage[k].wallmin_t); +#ifdef HAVE_PAPI + for (n = 0; n < nevents; ++n) { + fprintf (fp, " %12.6e", storage[k].papitotal[n]); + + fprintf (fp, " %9.3e (%6d %6d)", + storage[k].papimax[n], storage[k].papimax_p[n], + storage[k].papimax_t[n]); + + fprintf (fp, " %9.3e (%6d %6d)", + storage[k].papimin[n], storage[k].papimin_p[n], + storage[k].papimin_t[n]); + } +#endif + fprintf (fp, "\n"); + } + + fprintf (fp, "\n"); + free(tempname); + + } + else { /* iam != 0 (slave) */ +#ifdef HAVE_MPI + /* count number of timers from linked list */ + count = merge_thread_data(); + + /*allocate storage for data for all timers */ + if( !( storage = malloc( sizeof(Summarystats) * count ) ) && count ) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + if ( (ret = collect_data( iam, comm, &count, &storage ) ) != 0 ) + return GPTLerror ("%s: slave collect_data failed\n", thisfunc); +#endif + } + + free(timerlist[0]); + free(timerlist); + free(storage); + if (iam == 0 && fclose (fp) != 0) + fprintf (stderr, "%s: Attempt to close %s failed\n", thisfunc, outfile); + return 0; +} + +/* +** merge_thread_data: returns number of events in merged list +*/ + +static int merge_thread_data() +{ + int n, k, x; /*counters*/ + int t; /*current thread*/ + int num_newtimers; + int compare; + int *count; + int max_count; /* largest number of timers among non-thread-0 threads */ + char **newtimers; + int length = MAX_CHARS + 1; + char ***sort; + int count_r; /* count to be returned, allows *count to be free()ed */ + Timer *ptr; + + static const char *thisfunc = "merge_thread_data"; + + if( nthreads == 1 ) { /* merging is not needed since only 1 thread */ + + /* count timers for thread 0 */ + count_r = 0; + for (ptr = timers[0]->next; ptr; ptr = ptr->next) count_r++; + + timerlist = (char **) GPTLallocate( sizeof (char *)); + if( !( timerlist[0] = (char *)malloc( count_r * length * sizeof (char)) ) && count_r) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + x = 0; + for (ptr = timers[0]->next; ptr; ptr = ptr->next) { + strcpy((timerlist[0] + x), ptr->name); + x += length; + } + + return count_r; + + } + + timerlist = (char **) GPTLallocate( nthreads * sizeof (char *)); + count = (int *) GPTLallocate( nthreads * sizeof (int)); + sort = (char ***) GPTLallocate( nthreads * sizeof (void *)); + + max_count = 0; + for (t = 0; t < nthreads; t++) { + + /* count timers for thread */ + count[t] = 0; + for (ptr = timers[t]->next; ptr; ptr = ptr->next) count[t]++; + + if( count[t] > max_count || max_count == 0 ) max_count = count[t]; + + if( !( sort[t] = (char **)malloc( count[t] * sizeof (char *)) ) && count[t]) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + /* allocate memory to hold list of timer names */ + if( !( timerlist[t] = (char *)malloc( length * count[t] * sizeof (char)) ) && count[t]) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + memset( timerlist[t], length * count[t] * sizeof (char), 0 ); + + x = 0; + for (ptr = timers[t]->next; ptr; ptr = ptr->next) { + strcpy((timerlist[t] + x), ptr->name); + x += length; + } + + x = 0; + for (k = 0; k < count[t]; k++) { + sort[t][k] = timerlist[t] + x; + x += length; + } + + qsort( sort[t], count[t], sizeof (char *), cmp ); + + } + + if( !( newtimers = (char **)malloc( max_count * sizeof (char *)) ) && max_count) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + for (t = 1; t < nthreads; t++) { + memset( newtimers, max_count * sizeof (char *), 0 ); + k = 0; + n = 0; + num_newtimers = 0; + while( k < count[0] && n < count[t] ) { + /* linear comparison of timers */ + compare = strcmp( sort[0][k], sort[t][n] ); + + if( compare == 0 ) { + /* both have, nothing needs to be done */ + k++; + n++; + continue; + } + + if( compare < 0 ) { + /* event that only master has, nothing needs to be done */ + k++; + continue; + } + + if( compare > 0 ) { + /* event that only slave thread has, need to add */ + newtimers[num_newtimers] = sort[t][n]; + n++; + num_newtimers++; + } + } + + while( n < count[t] ) { + /* adds any remaining timers, since we know that all the rest + are new since have checked all master thread timers */ + newtimers[num_newtimers] = sort[t][n]; + num_newtimers++; + n++; + } + + if( num_newtimers ) { + /* sorts by memory address to restore original order */ + qsort( newtimers, num_newtimers, sizeof(char*), ncmp ); + + /* reallocate memory to hold additional timers */ + if( !( sort[0] = realloc( sort[0], (count[0] + num_newtimers) * sizeof (char *)) ) ) + return GPTLerror ("%s: memory reallocation failed\n", thisfunc); + if( !(timerlist[0] = realloc(timerlist[0], length * (count[0] + num_newtimers) * sizeof (char)) ) ) + return GPTLerror ("%s: memory reallocation failed\n", thisfunc); + + k = count[0]; + for (n = 0; n < num_newtimers; n++) { + /* add new found timers */ + memcpy( timerlist[0] + (count[0] + n) * length, newtimers[n], length * sizeof (char) ); + } + + count[0] += num_newtimers; + + /* reassign pointers in sort since realloc will have broken them if it moved the memory. */ + x = 0; + for (k = 0; k < count[0]; k++) { + sort[0][k] = timerlist[0] + x; + x += length; + } + + qsort( sort[0], count[0], sizeof (char *), cmp ); + } + } + + free(sort[0]); + /* don't free timerlist[0], since needed for subsequent steps in gathering global statistics */ + for (t = 1; t < nthreads; t++) { + free(sort[t]); + free(timerlist[t]); + } + + free(sort); + count_r = count[0]; + free(count); + + return count_r; +} + +/* +** collect data: compute global stats using tree reduction algorithm +** returns pointer to new summarystats list +** +** Input arguments: +** iam: process id +** comm: MPI communicator +** Input/Output arguments: +** summarystats: max/min/etc stats over all processes and threads +** count: number of events +** timerlist: list of all timer names (global variable) +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +#ifdef HAVE_MPI +static int collect_data(const int iam, + MPI_Comm comm, + int *count, + Summarystats **summarystats_cumul ) +#else +static int collect_data(const int iam, + int comm, + int *count, + Summarystats **summarystats_cumul ) +#endif +{ + int step; /* spacing beween active processes */ + int mstep; /* spacing between active masters */ + int procid; /* process to communicate with */ + int ret; + int nproc; + int signal = 1; + int x, k, n; /* counters */ + char *tempname; + int s = (MAX_CHARS + 1 ); /* spacing between timer names */ + int length = MAX_CHARS + 1; + int compare; + int num_newtimers; + int count_slave; + char *timers_slave; /* slave timerlist */ + char **newtimers; + char **sort_slave; /* slave sorted list */ + char **sort_master; /* master sorted list */ + int m_index, s_index; + Summarystats *summarystats; /* stats collected on master */ + + static const char *thisfunc = "collect_data"; + +#ifdef HAVE_MPI + Summarystats *summarystats_slave; /* stats sent to master */ + const int taga = 99; + const int tagb = 100; + const int tagc = 101; + MPI_Status status; + MPI_Request rcvreq1; + MPI_Request rcvreq2; + MPI_Request rcvreq3; + + if ((ret = MPI_Comm_size (comm, &nproc)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Comm_size=%d\n", thisfunc, iam, ret); + +#endif + + summarystats = *summarystats_cumul; + + if (!( tempname = (char*)malloc((MAX_CHARS +1) * sizeof(char) ) )) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + x = 0; + for (k = 0; k < *count; k++) { + memcpy( tempname, timerlist[0] + x, (MAX_CHARS + 1) * sizeof (char) ); + /* calculate individual stats */ + get_threadstats( iam, tempname, &summarystats[k]); + x += (MAX_CHARS + 1); + } + +#ifdef HAVE_MPI + step = 1; + mstep = 2; + while( step < nproc ) { + + if ((iam % mstep) == 0) { + /* find new masters at the current level, which are at every n*step starting with 0 */ + + procid = iam + step; + if (procid < nproc) { + /* prevent lone master wanting data from nonexistent process problem */ + + /* prepare for receive */ + if ((ret = MPI_Irecv (&count_slave, 1, MPI_INTEGER, procid, taga, comm, &rcvreq2)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Irecv=%d\n", thisfunc, iam, ret); + + /* handshake with slave */ + if ((ret = MPI_Send (&signal, 1, MPI_INTEGER, procid, taga, comm)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); + + /* wait for message from slave */ + if ((ret = MPI_Wait (&rcvreq2, MPI_STATUS_IGNORE)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Wait=%d\n", thisfunc, iam, ret); + + if (count_slave != 0) { /* if slave had no events, then nothing needs to be done*/ + + if (!(sort_master = (char **) malloc( (*count) * sizeof (char *) ) ) && (*count)) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + if (!(newtimers = (char **) malloc( count_slave * sizeof (char *) ) )) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + if (!(sort_slave = (char **) malloc( count_slave * sizeof (char *) ) )) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + if (!(summarystats_slave = (Summarystats *) malloc( count_slave * sizeof (Summarystats) ) )) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + if (!(timers_slave = (char *) malloc( count_slave * (MAX_CHARS + 1) * sizeof (char) ) )) + return GPTLerror ("%s: memory allocation failed\n", thisfunc); + + if ((ret = MPI_Irecv (timers_slave, count_slave * (MAX_CHARS + 1), MPI_CHAR, procid, tagb, comm, &rcvreq3)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Irecv=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Irecv (summarystats_slave, count_slave * sizeof(Summarystats), MPI_BYTE, procid, tagc, comm, &rcvreq1)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Irecv=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Send (&signal, 1, MPI_INT, procid, tagb, comm)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Wait (&rcvreq1, MPI_STATUS_IGNORE)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Wait=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Wait (&rcvreq3, MPI_STATUS_IGNORE)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Wait=%d\n", thisfunc, iam, ret); + + x = 0; + for (k = 0; k < count_slave; k++) { + sort_slave[k] = timers_slave + x; + x += MAX_CHARS + 1; + } + x = 0; + for (k = 0; k < *count; k++) { + sort_master[k] = timerlist[0] + x; + x += MAX_CHARS + 1; + } + + qsort(sort_master, *count, sizeof(char*), cmp); + qsort(sort_slave, count_slave, sizeof(char*), cmp); + + num_newtimers = 0; + n = 0; + k = 0; + while (k < *count && n < count_slave) + { + compare = strcmp(sort_master[k], sort_slave[n]); + + if (compare == 0) { + /* matching timers found */ + + /* find element number of the name in original timerlist so that it can be matched with its summarystats */ + m_index = get_index( timerlist[0], sort_master[k] ); + + s_index = get_index( timers_slave, sort_slave[n] ); + get_summarystats (&summarystats[m_index], &summarystats_slave[s_index]); + k++; + n++; + continue; + } + + if (compare > 0) { + /* s1 >s2 . slave has event; master does not */ + newtimers[num_newtimers] = sort_slave[n]; + num_newtimers++; + n++; + continue; + } + + if (compare < 0) /* only master has event; nothing needs to be done */ + k++; + } + + while (n < count_slave) { + /* add all remaining timers which only the slave has */ + newtimers[num_newtimers] = sort_slave[n]; + num_newtimers++; + n++; + } + + /* sort by memory address to get original order */ + qsort (newtimers, num_newtimers, sizeof(char*), ncmp); + + /* reallocate to hold new timer names and summary stats from slave */ + if (!(timerlist[0] = realloc( timerlist[0], length * (*count + num_newtimers) * sizeof (char) ) )) + return GPTLerror ("%s: memory reallocation failed\n", thisfunc); + if (!(summarystats = realloc( summarystats, (*count + count_slave ) * sizeof (Summarystats) ) )) + return GPTLerror ("%s: memory reallocation failed\n", thisfunc); + + k = *count; + x = *count * (MAX_CHARS + 1); + for (n = 0; n < num_newtimers; n++) { + /* copy new timers names and new timer data */ + memcpy(timerlist[0] + x, newtimers[n], length * sizeof (char)); + s_index = get_index( timers_slave, newtimers[n] ); + memcpy(&summarystats[k], &summarystats_slave[s_index], sizeof (Summarystats)); + k++; + x += MAX_CHARS + 1; + } + *count += num_newtimers; + + free(timers_slave); + free(summarystats_slave); + free(newtimers); + free(sort_slave); + free(sort_master); + } + + } + + } + else if ( (iam % step) == 0 ) { + /* non masters send data */ + + procid = iam - step; + + /* wait for ready signal from master */ + if ((ret = MPI_Recv (&signal, 1, MPI_INTEGER, procid, taga, comm, MPI_STATUS_IGNORE)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Recv=%d\n", thisfunc, iam, ret); + + if ((ret = MPI_Send (count, 1, MPI_INTEGER, procid, taga, comm)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); + + if ( count != 0) { + if ((ret = MPI_Recv (&signal, 1, MPI_INTEGER, procid, tagb, comm, MPI_STATUS_IGNORE)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Recv=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Send (timerlist[0], (*count) * (MAX_CHARS + 1), MPI_CHAR, procid, tagb, comm)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); + if ((ret = MPI_Send (summarystats, (*count) * sizeof(Summarystats), MPI_BYTE, procid, tagc, comm)) != MPI_SUCCESS) + return GPTLerror ("%s rank %d: Bad return from MPI_Send=%d\n", thisfunc, iam, ret); + } + free(tempname); + *summarystats_cumul = summarystats; + return 0; + + } + + step = mstep; + mstep = 2 * mstep; + + } + +#endif + + free(tempname); + *summarystats_cumul = summarystats; + return 0; +} + +/* +** get_index: calculates the index number of an element in a list +** based on the start memory address and memory address of the element +** where each element is MAX_CHARS+1 long +** +** Input arguments: +** list: start address of list +** element: start address of element +** +** Return value: index of element in list +*/ + +int get_index( const char * list, + const char * element ) +{ + return (( element - list ) / ( MAX_CHARS + 1 )); +} + + +/* +** cmp: returns value from strcmp. for use with qsort +*/ + +static int cmp(const void *pa, const void *pb) +{ + const char** x = (const char**)pa; + const char** y = (const char**)pb; + return strcmp(*x, *y); +} + + +/* +** ncmp: compares values of memory adresses pointed to by a pointer. for use with qsort +*/ + +static int ncmp( const void *pa, const void *pb ) +{ + static const char *thisfunc = "GPTLsetoption"; + const char** x = (const char**)pa; + const char** y = (const char**)pb; + + if( *x > *y ) + return 1; + if( *x < *y ) + return -1; + if( *x == *y ) + GPTLerror("%s: shared memory address between timers\n", thisfunc); +} + +/* +** get_threadstats: gather stats for timer "name" over all threads +** +** Input arguments: +** iam: MPI process id +** name: timer name +** Output arguments: +** summarystats: max/min stats over all threads +*/ + +void get_threadstats (const int iam, + const char *name, + Summarystats *summarystats) +{ +#ifdef HAVE_PAPI + int n; /* event index */ +#endif + int t; /* thread index */ + unsigned int indx; /* returned from getentry() */ + Timer *ptr; /* timer */ + + /* + ** This memset fortuitiously initializes the process values (_p) to master (0) + */ + + memset (summarystats, 0, sizeof (Summarystats)); + + summarystats->wallmax_p = iam; + summarystats->wallmin_p = iam; + + for (t = 0; t < nthreads; ++t) { + if ((ptr = getentry (hashtable[t], name, &indx))) { + + if (ptr->count > 0) { + summarystats->threads++; + summarystats->walltotal += ptr->wall.accum; + } + summarystats->count += ptr->count; + + if (ptr->wall.accum > summarystats->wallmax) { + summarystats->wallmax = ptr->wall.accum; + summarystats->wallmax_t = t; + } + + if (ptr->wall.accum < summarystats->wallmin || summarystats->wallmin == 0.) { + summarystats->wallmin = ptr->wall.accum; + summarystats->wallmin_t = t; + } +#ifdef HAVE_PAPI + for (n = 0; n < nevents; ++n) { + double value; + if (GPTL_PAPIget_eventvalue (eventlist[n].namestr, &ptr->aux, &value) != 0) { + fprintf (stderr, "Bad return from GPTL_PAPIget_eventvalue\n"); + return; + } + summarystats->papimax_p[n] = iam; + summarystats->papimin_p[n] = iam; + + if (value > summarystats->papimax[n]) { + summarystats->papimax[n] = value; + summarystats->papimax_t[n] = t; + } + + if (value < summarystats->papimin[n] || summarystats->papimin[n] == 0.) { + summarystats->papimin[n] = value; + summarystats->papimin_t[n] = t; + } + summarystats->papitotal[n] += value; + } +#endif + } + } + if ( summarystats->count ) summarystats->processes = 1; +} + +/* +** get_summarystats: write max/min stats into mpistats based on comparison +** with summarystats_slave +** +** Input arguments: +** summarystats_slave: stats from a slave process +** Input/Output arguments: +** summarystats: stats (starts out as master stats) +*/ + +void get_summarystats (Summarystats *summarystats, + const Summarystats *summarystats_slave) +{ + if (summarystats_slave->count == 0) return; + + if (summarystats_slave->wallmax > summarystats->wallmax) { + summarystats->wallmax = summarystats_slave->wallmax; + summarystats->wallmax_p = summarystats_slave->wallmax_p; + summarystats->wallmax_t = summarystats_slave->wallmax_t; + } + + if ((summarystats_slave->wallmin < summarystats->wallmin) || + (summarystats->count == 0)){ + summarystats->wallmin = summarystats_slave->wallmin; + summarystats->wallmin_p = summarystats_slave->wallmin_p; + summarystats->wallmin_t = summarystats_slave->wallmin_t; + } + +#ifdef HAVE_PAPI + { + int n; + for (n = 0; n < nevents; ++n) { + if (summarystats_slave->papimax[n] > summarystats->papimax[n]) { + summarystats->papimax[n] = summarystats_slave->papimax[n]; + summarystats->papimax_p[n] = summarystats_slave->papimax_p[n]; + summarystats->papimax_t[n] = summarystats_slave->papimax_t[n]; + } + + if ((summarystats_slave->papimin[n] < summarystats->papimin[n]) || + (summarystats->count == 0)){ + summarystats->papimin[n] = summarystats_slave->papimin[n]; + summarystats->papimin_p[n] = summarystats_slave->papimin_p[n]; + summarystats->papimin_t[n] = summarystats_slave->papimin_t[n]; + } + summarystats->papitotal[n] += summarystats_slave->papitotal[n]; + } + } +#endif + + summarystats->count += summarystats_slave->count; + summarystats->walltotal += summarystats_slave->walltotal; + summarystats->processes += summarystats_slave->processes; + summarystats->threads += summarystats_slave->threads; +} + +/* +** GPTLbarrier: When MPI enabled, set and time an MPI barrier +** +** Input arguments: +** comm: commuicator (e.g. MPI_COMM_WORLD). If zero, use MPI_COMM_WORLD +** name: region name +** +** Return value: 0 (success) +*/ + +#ifdef HAVE_MPI +int GPTLbarrier (MPI_Comm comm, const char *name) +#else +int GPTLbarrier (int comm, const char *name) +#endif +{ + int ret; + static const char *thisfunc = "GPTLbarrier"; + + ret = GPTLstart (name); +#ifdef HAVE_MPI + if ((ret = MPI_Barrier (comm)) != MPI_SUCCESS) + return GPTLerror ("%s: Bad return from MPI_Barrier=%d", thisfunc, ret); +#endif + ret = GPTLstop (name); + return 0; +} + +/* +** get_cpustamp: Invoke the proper system timer and return stats. +** +** Output arguments: +** usr: user time +** sys: system time +** +** Return value: 0 (success) +*/ + +static inline int get_cpustamp (long *usr, long *sys) +{ +#ifdef HAVE_TIMES + struct tms buf; + + (void) times (&buf); + *usr = buf.tms_utime; + *sys = buf.tms_stime; + return 0; +#else + return GPTLerror ("get_cpustamp: times() not available\n"); +#endif +} + +/* +** GPTLquery: return current status info about a timer. If certain stats are not +** enabled, they should just have zeros in them. If PAPI is not enabled, input +** counter info is ignored. +** +** Input args: +** name: timer name +** maxcounters: max number of PAPI counters to get info for +** t: thread number (if < 0, the request is for the current thread) +** +** Output args: +** count: number of times this timer was called +** onflg: whether timer is currently on +** wallclock: accumulated wallclock time +** usr: accumulated user CPU time +** sys: accumulated system CPU time +** papicounters_out: accumulated PAPI counters +*/ + +int GPTLquery (const char *name, + int t, + int *count, + int *onflg, + double *wallclock, + double *dusr, + double *dsys, + long long *papicounters_out, + const int maxcounters) +{ + Timer *ptr; /* linked list pointer */ + unsigned int indx; /* linked list index returned from getentry (unused) */ + static const char *thisfunc = "GPTLquery"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: get_thread_num failure\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + ptr = getentry (hashtable[t], name, &indx); + if ( !ptr) + return GPTLerror ("%s: requested timer %s does not have a name hash\n", thisfunc, name); + + *onflg = ptr->onflg; + *count = ptr->count; + *wallclock = ptr->wall.accum; + *dusr = ptr->cpu.accum_utime / (double) ticks_per_sec; + *dsys = ptr->cpu.accum_stime / (double) ticks_per_sec; +#ifdef HAVE_PAPI + GPTL_PAPIquery (&ptr->aux, papicounters_out, maxcounters); +#endif + return 0; +} + +/* +** GPTLquerycounters: return current PAPI counters for a timer. +** THIS ROUTINE ID DEPRECATED. USE GPTLget_eventvalue() instead +** +** Input args: +** name: timer name +** t: thread number (if < 0, the request is for the current thread) +** +** Output args: +** papicounters_out: accumulated PAPI counters +*/ + +int GPTLquerycounters (const char *name, + int t, + long long *papicounters_out) +{ + Timer *ptr; /* linked list pointer */ + unsigned int indx; /* hash index returned from getentry */ + static const char *thisfunc = "GPTLquery_counters"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: get_thread_num failure\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + ptr = getentry (hashtable[t], name, &indx); + if ( !ptr) + return GPTLerror ("%s: requested timer %s does not have a name hash\n", thisfunc, name); + +#ifdef HAVE_PAPI + /* The 999 is a hack to say "give me all the counters" */ + GPTL_PAPIquery (&ptr->aux, papicounters_out, 999); +#endif + return 0; +} + +/* +** GPTLget_wallclock: return wallclock accumulation for a timer. +** +** Input args: +** timername: timer name +** t: thread number (if < 0, the request is for the current thread) +** +** Output args: +** value: current wallclock accumulation for the timer +*/ + +int GPTLget_wallclock (const char *timername, + int t, + double *value) +{ + void *self; /* timer address when hash entry generated with *_instr */ + Timer *ptr; /* linked list pointer */ + unsigned int indx; /* hash index returned from getentry (unused) */ + static const char *thisfunc = "GPTLget_wallclock"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + if ( ! wallstats.enabled) + return GPTLerror ("%s: wallstats not enabled\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + /* + ** Don't know whether hashtable entry for timername was generated with + ** *_instr() or not, so try both possibilities + */ + + ptr = getentry (hashtable[t], timername, &indx); + if ( !ptr) { + if (sscanf (timername, "%lx", (unsigned long *) &self) < 1) + return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); + ptr = getentry_instr (hashtable[t], self, &indx); + if ( !ptr) + return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); + } + + *value = ptr->wall.accum; + return 0; +} + +/* +** GPTLget_eventvalue: return PAPI-based event value for a timer. All values will be +** returned as doubles, even if the event is not derived. +** +** Input args: +** timername: timer name +** eventname: event name (must be currently enabled) +** t: thread number (if < 0, the request is for the current thread) +** +** Output args: +** value: current value of the event for this timer +*/ + +int GPTLget_eventvalue (const char *timername, + const char *eventname, + int t, + double *value) +{ + void *self; /* timer address when hash entry generated with *_instr */ + Timer *ptr; /* linked list pointer */ + unsigned int indx; /* hash index returned from getentry (unused) */ + static const char *thisfunc = "GPTLget_eventvalue"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: get_thread_num failure\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + /* + ** Don't know whether hashtable entry for timername was generated with + ** *_instr() or not, so try both possibilities + */ + + ptr = getentry (hashtable[t], timername, &indx); + if ( !ptr) { + if (sscanf (timername, "%lx", (unsigned long *) &self) < 1) + return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); + ptr = getentry_instr (hashtable[t], self, &indx); + if ( !ptr) + return GPTLerror ("%s: requested timer %s does not exist\n", thisfunc, timername); + } + +#ifdef HAVE_PAPI + return GPTL_PAPIget_eventvalue (eventname, &ptr->aux, value); +#else + return GPTLerror ("%s: PAPI not enabled\n", thisfunc); +#endif +} + +/* +** GPTLget_nregions: return number of regions (i.e. timer names) for this thread +** +** Input args: +** t: thread number (if < 0, the request is for the current thread) +** +** Output args: +** nregions: number of regions +*/ + +int GPTLget_nregions (int t, + int *nregions) +{ + Timer *ptr; /* walk through linked list */ + static const char *thisfunc = "GPTLget_nregions"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: get_thread_num failure\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + *nregions = 0; + for (ptr = timers[t]->next; ptr; ptr = ptr->next) + ++*nregions; + + return 0; +} + +/* +** GPTLget_regionname: return region name for this thread +** +** Input args: +** t: thread number (if < 0, the request is for the current thread) +** region: region number +** nc: max number of chars to put in name +** +** Output args: +** name region name +*/ + +int GPTLget_regionname (int t, /* thread number */ + int region, /* region number (0-based) */ + char *name, /* output region name */ + int nc) /* number of chars in name (free form Fortran) */ +{ + int ncpy; /* number of characters to copy */ + int i; /* index */ + Timer *ptr; /* walk through linked list */ + static const char *thisfunc = "GPTLget_regionname"; + + if ( ! initialized) + return GPTLerror ("%s: GPTLinitialize has not been called\n", thisfunc); + + /* + ** If t is < 0, assume the request is for the current thread + */ + + if (t < 0) { + if ((t = get_thread_num ()) < 0) + return GPTLerror ("%s: get_thread_num failure\n", thisfunc); + } else { + if (t >= maxthreads) + return GPTLerror ("%s: requested thread %d is too big\n", thisfunc, t); + } + + ptr = timers[t]->next; + for (i = 0; i < region; i++) { + if ( ! ptr) + return GPTLerror ("%s: timer number %d does not exist in thread %d\n", thisfunc, region, t); + ptr = ptr->next; + } + + if (ptr) { + ncpy = MIN (nc, strlen (ptr->name)); + strncpy (name, ptr->name, ncpy); + + /* + ** Adding the \0 is only important when called from C + */ + + if (ncpy < nc) + name[ncpy] = '\0'; + } else { + return GPTLerror ("%s: timer number %d does not exist in thread %d\n", thisfunc, region, t); + } + return 0; +} + +/* +** GPTLis_initialized: Return whether GPTL has been initialized +*/ + +int GPTLis_initialized (void) +{ + return (int) initialized; +} + +/* +** getentry_instr: find hash table entry and return a pointer to it +** +** Input args: +** hashtable: the hashtable (array) +** self: input address (from -finstrument-functions) +** Output args: +** indx: hashtable index +** +** Return value: pointer to the entry, or NULL if not found +*/ + +static inline Timer *getentry_instr (const Hashentry *hashtable, /* hash table */ + void *self, /* address */ + unsigned int *indx) /* hash index */ +{ + int i; + Timer *ptr = 0; /* return value when entry not found */ + + /* + ** Hash index is timer address modulo the table size + ** On most machines, right-shifting the address helps because linkers often + ** align functions on even boundaries + */ + + *indx = (((unsigned long) self) >> 4) % tablesize; + for (i = 0; i < hashtable[*indx].nument; ++i) { + if (hashtable[*indx].entries[i]->address == self) { + ptr = hashtable[*indx].entries[i]; + break; + } + } + return ptr; +} + +/* +** getentry: find the entry in the hash table and return a pointer to it. +** +** Input args: +** hashtable: the hashtable (array) +** name: string to be hashed on (specifically, summed) +** Output args: +** indx: hashtable index +** +** Return value: pointer to the entry, or NULL if not found +*/ + +static inline Timer *getentry (const Hashentry *hashtable, /* hash table */ + const char *name, /* name to hash */ + unsigned int *indx) /* hash index */ +{ + int i; /* multiplier for hashing; loop index */ + const unsigned char *c; /* pointer to elements of "name" */ + Timer *ptr = 0; /* return value when entry not found */ + + /* + ** Hash value is sum of: chars times their 1-based position index, modulo tablesize + */ + + *indx = 0; + c = (unsigned char *) name; + for (i = 1; *c && i < MAX_CHARS+1; ++c, ++i) { + *indx += (*c) * i; + } + + *indx %= tablesize; + + /* + ** If nument exceeds 1 there was a hash collision and we must search + ** linearly through an array for a match + */ + + for (i = 0; i < hashtable[*indx].nument; i++) { + if (STRMATCH (name, hashtable[*indx].entries[i]->name)) { + ptr = hashtable[*indx].entries[i]; + break; + } + } + return ptr; +} + +/* +** getentryf: find the entry in the hash table and return a pointer to it. +** (variant of getentry where string length is included because string +** may not be null terminated) +** +** Input args: +** hashtable: the hashtable (array) +** name: string to be hashed on (specifically, summed) +** namelen: number of characters in string +** Output args: +** indx: hashtable index +** +** Return value: pointer to the entry, or NULL if not found +*/ + +static inline Timer *getentryf (const Hashentry *hashtable, /* hash table */ + const char *name, /* name to hash */ + const int namelen, /* length of name */ + unsigned int *indx) /* hash index */ +{ + int i; /* multiplier for hashing; loop index */ + int numchars; /* maximum number of characters to examine */ + const unsigned char *c; /* pointer to elements of "name" */ + Timer *ptr = 0; /* return value when entry not found */ + + numchars = MIN (namelen, MAX_CHARS); + + /* + ** Hash value is sum of: chars times their 1-based position index, modulo tablesize + */ + + *indx = 0; + c = (unsigned char *) name; + for (i = 1; i < numchars+1; ++c, ++i) { + *indx += (*c) * i; + } + + *indx %= tablesize; + + /* + ** If nument exceeds 1 there was a hash collision and we must search + ** linearly through an array for a match + */ + + for (i = 0; i < hashtable[*indx].nument; i++) { + if (STRNMATCH (name, hashtable[*indx].entries[i]->name,numchars)) { + ptr = hashtable[*indx].entries[i]; + break; + } + } + return ptr; +} + +/* +** Add entry points for auto-instrumented codes +** Auto instrumentation flags for various compilers: +** +** gcc, pathcc, icc: -finstrument-functions +** pgcc: -Minstrument:functions +** xlc: -qdebug=function_trace +*/ + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef AUTO_INST +#ifdef _AIX +void __func_trace_enter (const char *function_name, + const char *file_name, + int line_number, + void **const user_data) +{ + (void) GPTLstart (function_name); +} + +void __func_trace_exit (const char *function_name, + const char *file_name, + int line_number, + void **const user_data) +{ + (void) GPTLstop (function_name); +} + +#else + +void __cyg_profile_func_enter (void *this_fn, + void *call_site) +{ + (void) GPTLstart_instr (this_fn); +} + +void __cyg_profile_func_exit (void *this_fn, + void *call_site) +{ + (void) GPTLstop_instr (this_fn); +} +#endif +#endif + +#ifdef __cplusplus +}; +#endif + +#ifdef HAVE_NANOTIME +#ifdef BIT64 +/* 64-bit code copied from PAPI library */ +static inline unsigned long long nanotime (void) +{ + unsigned long long val; + do { + unsigned int a,d; + asm volatile("rdtsc" : "=a" (a), "=d" (d)); + (val) = ((unsigned long)a) | (((unsigned long)d)<<32); + } while(0); + + return (val); +} +#else +static inline unsigned long long nanotime (void) +{ + unsigned long long val; + __asm__ __volatile__("rdtsc" : "=A" (val) : ); + return (val); +} +#endif + +#define LEN 4096 + +static float get_clockfreq () +{ + FILE *fd = 0; + char buf[LEN]; + int is; + + if ( ! (fd = fopen ("/proc/cpuinfo", "r"))) { + fprintf (stderr, "get_clockfreq: can't open /proc/cpuinfo\n"); + return -1.; + } + + while (fgets (buf, LEN, fd)) { + if (strncmp (buf, "cpu MHz", 7) == 0) { + for (is = 7; buf[is] != '\0' && !isdigit (buf[is]); is++); + if (isdigit (buf[is])) + return (float) atof (&buf[is]); + } + } + + return -1.; +} +#endif + +/* +** The following are the set of underlying timing routines which may or may +** not be available. And their accompanying init routines. +** NANOTIME is currently only available on x86. +*/ + +static int init_nanotime () +{ + static const char *thisfunc = "init_nanotime"; +#ifdef HAVE_NANOTIME + if ((cpumhz = get_clockfreq ()) < 0) + return GPTLerror ("%s: Can't get clock freq\n", thisfunc); + + if (verbose) + printf ("%s: Clock rate = %f MHz\n", thisfunc, cpumhz); + + cyc2sec = 1./(cpumhz * 1.e6); + return 0; +#else + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_nanotime () +{ +#ifdef HAVE_NANOTIME + double timestamp; + timestamp = nanotime () * cyc2sec; + return timestamp; +#else + static const char *thisfunc = "utr_nanotime"; + (void) GPTLerror ("%s: not enabled\n", thisfunc); + return -1.; +#endif +} + +/* +** MPI_Wtime requires the MPI lib. +*/ + +static int init_mpiwtime () +{ +#ifdef HAVE_MPI + return 0; +#else + static const char *thisfunc = "init_mpiwtime"; + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_mpiwtime () +{ +#ifdef HAVE_MPI + return MPI_Wtime (); +#else + static const char *thisfunc = "utr_mpiwtime"; + (void) GPTLerror ("%s: not enabled\n", thisfunc); + return -1.; +#endif +} + +/* +** PAPI_get_real_usec requires the PAPI lib. +*/ + +static int init_papitime () +{ + static const char *thisfunc = "init_papitime"; +#ifdef HAVE_PAPI + ref_papitime = PAPI_get_real_usec (); + if (verbose) + printf ("%s: ref_papitime=%ld\n", thisfunc, (long) ref_papitime); + return 0; +#else + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_papitime () +{ +#ifdef HAVE_PAPI + return (PAPI_get_real_usec () - ref_papitime) * 1.e-6; +#else + static const char *thisfunc = "utr_papitime"; + (void) GPTLerror ("%s: not enabled\n", thisfunc); + return -1.; +#endif +} + +/* +** Probably need to link with -lrt for this one to work +*/ + +static int init_clock_gettime () +{ + static const char *thisfunc = "init_clock_gettime"; +#ifdef HAVE_LIBRT + struct timespec tp; + (void) clock_gettime (CLOCK_REALTIME, &tp); + ref_clock_gettime = tp.tv_sec; + if (verbose) + printf ("%s: ref_clock_gettime=%ld\n", thisfunc, (long) ref_clock_gettime); + return 0; +#else + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_clock_gettime () +{ +#ifdef HAVE_LIBRT + struct timespec tp; + (void) clock_gettime (CLOCK_REALTIME, &tp); + return (tp.tv_sec - ref_clock_gettime) + 1.e-9*tp.tv_nsec; +#else + static const char *thisfunc = "utr_clock_gettime"; + (void) GPTLerror ("%s: not enabled\n", thisfunc); + return -1.; +#endif +} + +/* +** High-res timer on AIX: read_real_time +*/ + +static int init_read_real_time () +{ + static const char *thisfunc = "init_read_real_time"; +#ifdef _AIX + timebasestruct_t ibmtime; + (void) read_real_time (&ibmtime, TIMEBASE_SZ); + (void) time_base_to_time (&ibmtime, TIMEBASE_SZ); + ref_read_real_time = ibmtime.tb_high; + if (verbose) + printf ("%s: ref_read_real_time=%ld\n", thisfunc, (long) ref_read_real_time); + return 0; +#else + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_read_real_time () +{ +#ifdef _AIX + timebasestruct_t ibmtime; + (void) read_real_time (&ibmtime, TIMEBASE_SZ); + (void) time_base_to_time (&ibmtime, TIMEBASE_SZ); + return (ibmtime.tb_high - ref_read_real_time) + 1.e-9*ibmtime.tb_low; +#else + static const char *thisfunc = "utr_read_real_time"; + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +/* +** Default available most places: gettimeofday +*/ + +static int init_gettimeofday () +{ + static const char *thisfunc = "init_gettimeofday"; +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + (void) gettimeofday (&tp, 0); + ref_gettimeofday = tp.tv_sec; + if (verbose) + printf ("%s: ref_gettimeofday=%ld\n", thisfunc, (long) ref_gettimeofday); + return 0; +#else + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +static inline double utr_gettimeofday () +{ +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + (void) gettimeofday (&tp, 0); + return (tp.tv_sec - ref_gettimeofday) + 1.e-6*tp.tv_usec; +#else + static const char *thisfunc = "utr_gettimeofday"; + return GPTLerror ("%s: not enabled\n", thisfunc); +#endif +} + +/* +** Determine underlying timing routine overhead: call it 1000 times. +*/ + +static double utr_getoverhead () +{ + double val2[1001]; + int i; + + val2[0] = (*ptr2wtimefunc)(); + for (i = 1; i < 1001; ++i) { + val2[i] = (*ptr2wtimefunc)(); + } + return 0.001 * (val2[1000] - val2[0]); +} + +/* +** printself_andchildren: Recurse through call tree, printing stats for self, then children +*/ + +static void printself_andchildren (const Timer *ptr, + FILE *fp, + const int t, + const int depth, + const double tot_overhead) +{ + int n; + + if (depth > -1) /* -1 flag is to avoid printing stats for dummy outer timer */ + printstats (ptr, fp, t, depth, true, tot_overhead); + + for (n = 0; n < ptr->nchildren; n++) + printself_andchildren (ptr->children[n], fp, t, depth+1, tot_overhead); +} + +#ifdef ENABLE_PMPI +/* +** GPTLgetentry: called ONLY from pmpi.c (i.e. not a public entry point). Returns a pointer to the +** requested timer name by calling internal function getentry() +** +** Return value: 0 (NULL) or the return value of getentry() +*/ + +Timer *GPTLgetentry (const char *name) +{ + int t; /* thread number */ + unsigned int indx; /* returned from getentry (unused) */ + static const char *thisfunc = "GPTLgetentry"; + + if ( ! initialized) { + (void) GPTLerror ("%s: initialization was not completed\n", thisfunc); + return 0; + } + + if ((t = get_thread_num ()) < 0) { + (void) GPTLerror ("%s: bad return from get_thread_num\n", thisfunc); + return 0; + } + + return (getentry (hashtable[t], name, &indx)); +} + +/* +** GPTLpr_file_has_been_called: Called ONLY from pmpi.c (i.e. not a public entry point). Return +** whether GPTLpr_file has been called. MPI_Finalize wrapper needs +** to know whether it needs to call GPTLpr. +*/ + +int GPTLpr_has_been_called (void) +{ + return (int) pr_has_been_called; +} + +#endif + +/*************************************************************************************/ + +/* +** Contents of inserted threadutil.c starts here. +** Moved to gptl.c to enable inlining +*/ + +/* +** $Id: gptl.c,v 1.157 2011-03-28 20:55:18 rosinski Exp $ +** +** Author: Jim Rosinski +** +** Utility functions handle thread-based GPTL needs. +*/ + +/* Max allowable number of threads (used only when THREADED_PTHREADS is true) */ +#define MAX_THREADS 128 + +/**********************************************************************************/ +/* +** 3 sets of routines: OMP threading, PTHREADS, unthreaded +*/ + +#if ( defined THREADED_OMP ) + +/* +** threadinit: Allocate and initialize threadid_omp; set max number of threads +** +** Output results: +** maxthreads: max number of threads +** +** threadid_omp[] is allocated and initialized to -1 +** +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static int threadinit (void) +{ + int t; /* loop index */ + static const char *thisfunc = "threadinit"; + + if (omp_get_thread_num () != 0) + return GPTLerror ("OMP %s: MUST only be called by the master thread\n", thisfunc); + + /* + ** Allocate the threadid array which maps physical thread IDs to logical IDs + ** For OpenMP this will be just threadid_omp[iam] = iam; + */ + + if (threadid_omp) + return GPTLerror ("OMP %s: has already been called.\nMaybe mistakenly called by multiple threads?", + thisfunc); + + maxthreads = MAX ((1), (omp_get_max_threads ())); + if ( ! (threadid_omp = (int *) GPTLallocate (maxthreads * sizeof (int)))) + return GPTLerror ("OMP %s: malloc failure for %d elements of threadid_omp\n", thisfunc, maxthreads); + + /* + ** Initialize threadid array to flag values for use by get_thread_num(). + ** get_thread_num() will fill in the values on first use. + */ + + for (t = 0; t < maxthreads; ++t) + threadid_omp[t] = -1; + +#ifdef VERBOSE + printf ("OMP %s: Set maxthreads=%d\n", thisfunc, maxthreads); +#endif + + return 0; +} + +/* +** Threadfinalize: clean up +** +** Output results: +** threadid_omp array is freed and array pointer nullified +*/ + +static void threadfinalize () +{ + free ((void *) threadid_omp); + threadid_omp = 0; +} + +/* +** get_thread_num: Determine thread number of the calling thread +** Start PAPI counters if enabled and first call for this thread. +** +** Output results: +** nthreads: Number of threads (=maxthreads) +** threadid_omp: Our thread id added to list on 1st call +** +** Return value: thread number (success) or GPTLerror (failure) +*/ + +static inline int get_thread_num (void) +{ + int t; /* thread number */ + static const char *thisfunc = "get_thread_num"; + + if ((t = omp_get_thread_num ()) >= maxthreads) + return GPTLerror ("OMP %s: returned id=%d exceeds maxthreads=%d\n", thisfunc, t, maxthreads); + + /* + ** If our thread number has already been set in the list, we are done + */ + + if (t == threadid_omp[t]) + return t; + + /* + ** Thread id not found. Modify threadid_omp with our ID, then start PAPI events if required. + ** Due to the setting of threadid_omp, everything below here will only execute once per thread. + */ + + threadid_omp[t] = t; + +#ifdef VERBOSE + printf ("OMP %s: 1st call t=%d\n", thisfunc, t); +#endif + +#ifdef HAVE_PAPI + + /* + ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, + ** create and start an event set for the new thread. + */ + + if (GPTLget_npapievents () > 0) { +#ifdef VERBOSE + printf ("OMP %s: Starting EventSet t=%d\n", thisfunc, t); +#endif + + if (GPTLcreate_and_start_events (t) < 0) + return GPTLerror ("OMP %s: error from GPTLcreate_and_start_events for thread %d\n", thisfunc, t); + } +#endif + + /* + ** nthreads = maxthreads based on setting in threadinit + */ + + nthreads = maxthreads; +#ifdef VERBOSE + printf ("OMP %s: nthreads=%d\n", thisfunc, nthreads); +#endif + + return t; +} + +static void print_threadmapping (FILE *fp) +{ + int n; + + fprintf (fp, "\n"); + fprintf (fp, "Thread mapping:\n"); + for (n = 0; n < nthreads; ++n) + fprintf (fp, "threadid_omp[%d] = %d\n", n, threadid_omp[n]); +} + +/**********************************************************************************/ +/* +** PTHREADS +*/ + +#elif ( defined THREADED_PTHREADS ) + +/* +** threadinit: Allocate threadid and initialize to -1; set max number of threads; +** Initialize the mutex for later use; Initialize nthreads to 0 +** +** Output results: +** nthreads: number of threads (init to zero here, increment later in get_thread_num) +** maxthreads: max number of threads (MAX_THREADS) +** +** threadid[] is allocated and initialized to -1 +** mutex is initialized for future use +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +static int threadinit (void) +{ + int t; /* thread number */ + int ret; /* return code */ + static const char *thisfunc = "threadinit"; + + /* + ** The following test is not rock-solid, but it's pretty close in terms of guaranteeing that + ** threadinit gets called by only 1 thread. Problem is, mutex hasn't yet been initialized + ** so we can't use it. + */ + + if (nthreads == -1) + nthreads = 0; + else + return GPTLerror ("PTHREADS %s: has already been called.\n" + "Maybe mistakenly called by multiple threads?\n", thisfunc); + + /* + ** Initialize the mutex required for critical regions. + ** Previously, t_mutex = PTHREAD_MUTEX_INITIALIZER on the static declaration line was + ** adequate to initialize the mutex. But this failed in programs that invoked + ** GPTLfinalize() followed by GPTLinitialize(). + ** "man pthread_mutex_init" indicates that passing NULL as the second argument to + ** pthread_mutex_init() should appropriately initialize the mutex, assuming it was + ** properly destroyed by a previous call to pthread_mutex_destroy(); + */ + +#ifdef MUTEX_API + if ((ret = pthread_mutex_init ((pthread_mutex_t *) &t_mutex, NULL)) != 0) + return GPTLerror ("PTHREADS %s: mutex init failure: ret=%d\n", thisfunc, ret); +#endif + + /* + ** Allocate the threadid array which maps physical thread IDs to logical IDs + */ + + if (threadid) + return GPTLerror ("PTHREADS %s: threadid not null\n", thisfunc); + else if ( ! (threadid = (pthread_t *) GPTLallocate (MAX_THREADS * sizeof (pthread_t)))) + return GPTLerror ("PTHREADS %s: malloc failure for %d elements of threadid\n", thisfunc, MAX_THREADS); + + maxthreads = MAX_THREADS; + + /* + ** Initialize threadid array to flag values for use by get_thread_num(). + ** get_thread_num() will fill in the values on first use. + */ + + for (t = 0; t < maxthreads; ++t) + threadid[t] = (pthread_t) -1; + +#ifdef VERBOSE + printf ("PTHREADS %s: Set maxthreads=%d nthreads=%d\n", thisfunc, maxthreads, nthreads); +#endif + + return 0; +} + +/* +** threadfinalize: Clean up +** +** Output results: +** threadid array is freed and array pointer nullified +** mutex is destroyed +*/ + +static void threadfinalize () +{ + int ret; + +#ifdef MUTEX_API + if ((ret = pthread_mutex_destroy ((pthread_mutex_t *) &t_mutex)) != 0) + printf ("threadfinalize: failed attempt to destroy t_mutex: ret=%d\n", ret); +#endif + free ((void *) threadid); + threadid = 0; +} + +/* +** get_thread_num: Determine zero-based thread number of the calling thread. +** Update nthreads and maxthreads if necessary. +** Start PAPI counters if enabled and first call for this thread. +** +** Output results: +** nthreads: Updated number of threads +** threadid: Our thread id added to list on 1st call +** +** Return value: thread number (success) or GPTLerror (failure) +*/ + +static inline int get_thread_num (void) +{ + int t; /* logical thread number, defined by array index of found threadid */ + pthread_t mythreadid; /* thread id from pthreads library */ + int retval; /* value to return to caller */ + bool foundit = false; /* thread id found in list */ + static const char *thisfunc = "get_thread_num"; + + mythreadid = pthread_self (); + + /* + ** If our thread number has already been set in the list, we are done + ** VECTOR code should run a bit faster on vector machines. + */ +#define VECTOR +#ifdef VECTOR + for (t = 0; t < nthreads; ++t) + if (pthread_equal (mythreadid, threadid[t])) { + foundit = true; + retval = t; + } + + if (foundit) + return retval; +#else + for (t = 0; t < nthreads; ++t) + if (pthread_equal (mythreadid, threadid[t])) + return t; +#endif + + /* + ** Thread id not found. Define a critical region, then start PAPI counters if + ** necessary and modify threadid[] with our id. + */ + + if (lock_mutex () < 0) + return GPTLerror ("PTHREADS %s: mutex lock failure\n", thisfunc); + + /* + ** If our thread id is not in the known list, add to it after checking that + ** we do not have too many threads. + */ + + if (nthreads >= MAX_THREADS) { + if (unlock_mutex () < 0) + fprintf (stderr, "PTHREADS %s: mutex unlock failure\n", thisfunc); + + return GPTLerror ("PTHREADS %s: nthreads=%d is too big. Recompile " + "with larger value of MAX_THREADS\n", thisfunc, nthreads); + } + + threadid[nthreads] = mythreadid; + +#ifdef VERBOSE + printf ("PTHREADS %s: 1st call threadid=%lu maps to location %d\n", + thisfunc, (unsigned long) mythreadid, nthreads); +#endif + +#ifdef HAVE_PAPI + + /* + ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, + ** create and start an event set for the new thread. + */ + + if (GPTLget_npapievents () > 0) { +#ifdef VERBOSE + printf ("PTHREADS get_thread_num: Starting EventSet threadid=%lu location=%d\n", + (unsigned long) mythreadid, nthreads); +#endif + if (GPTLcreate_and_start_events (nthreads) < 0) { + if (unlock_mutex () < 0) + fprintf (stderr, "PTHREADS %s: mutex unlock failure\n", thisfunc); + + return GPTLerror ("PTHREADS %s: error from GPTLcreate_and_start_events for thread %d\n", + thisfunc, nthreads); + } + } +#endif + + /* + ** IMPORTANT to set return value before unlocking the mutex!!!! + ** "return nthreads-1" fails occasionally when another thread modifies + ** nthreads after it gets the mutex! + */ + + retval = nthreads++; + +#ifdef VERBOSE + printf ("PTHREADS get_thread_num: nthreads bumped to %d\n", nthreads); +#endif + + if (unlock_mutex () < 0) + return GPTLerror ("PTHREADS %s: mutex unlock failure\n", thisfunc); + + return retval; +} + +/* +** lock_mutex: lock a mutex for private access +*/ + +static int lock_mutex () +{ + static const char *thisfunc = "lock_mutex"; + + if (pthread_mutex_lock ((pthread_mutex_t *) &t_mutex) != 0) + return GPTLerror ("%s: failure from pthread_lock_mutex\n", thisfunc); + + return 0; +} + +/* +** unlock_mutex: unlock a mutex from private access +*/ + +static int unlock_mutex () +{ + static const char *thisfunc = "unlock_mutex"; + + if (pthread_mutex_unlock ((pthread_mutex_t *) &t_mutex) != 0) + return GPTLerror ("%s: failure from pthread_unlock_mutex\n", thisfunc); + return 0; +} + +static void print_threadmapping (FILE *fp) +{ + int t; + + fprintf (fp, "\n"); + fprintf (fp, "Thread mapping:\n"); + for (t = 0; t < nthreads; ++t) + fprintf (fp, "threadid[%d] = %lu\n", t, (unsigned long) threadid[t]); +} + +/**********************************************************************************/ +/* +** Unthreaded case +*/ + +#else + +static int threadinit (void) +{ + static const char *thisfunc = "threadinit"; + + if (nthreads != -1) + return GPTLerror ("Unthreaded %s: MUST only be called once", thisfunc); + + nthreads = 0; + maxthreads = 1; + return 0; +} + +void threadfinalize () +{ + threadid = -1; +} + +static inline int get_thread_num () +{ + static const char *thisfunc = "get_thread_num"; +#ifdef HAVE_PAPI + /* + ** When HAVE_PAPI is true, if 1 or more PAPI events are enabled, + ** create and start an event set for the new thread. + */ + + if (threadid == -1 && GPTLget_npapievents () > 0) { + if (GPTLcreate_and_start_events (0) < 0) + return GPTLerror ("Unthreaded %s: error from GPTLcreate_and_start_events for thread %0\n", thisfunc); + + threadid = 0; + } +#endif + + nthreads = 1; + return 0; +} + +static void print_threadmapping (FILE *fp) +{ + fprintf (fp, "\n"); + fprintf (fp, "threadid[0] = 0\n"); +} + +#endif diff --git a/share/timing/gptl.h b/share/timing/gptl.h new file mode 100644 index 000000000000..70df08a07315 --- /dev/null +++ b/share/timing/gptl.h @@ -0,0 +1,167 @@ +/* +** $Id: gptl.h,v 1.59 2011-03-28 20:55:19 rosinski Exp $ +** +** Author: Jim Rosinski +** +** GPTL header file to be included in user code +*/ + +#ifndef GPTL_H +#define GPTL_H + +#ifdef INCLUDE_CMAKE_FCI +#include "cmake_fortran_c_interface.h" +#endif + +/* following block for camtimers only */ +#ifndef NO_GETTIMEOFDAY +#define HAVE_GETTIMEOFDAY +#endif + +#ifdef SPMD +#undef HAVE_MPI +#define HAVE_MPI +#endif + +#ifdef _OPENMP +#ifndef THREADED_PTHREADS +#define THREADED_OMP +#endif +#endif +/* above block for camtimers only */ + +#ifdef HAVE_MPI +#include +#endif + +/* +** Options settable by a call to GPTLsetoption() (default in parens) +** These numbers need to be small integers because GPTLsetoption can +** be passed PAPI counters, and we need to avoid collisions in that +** integer space. PAPI presets are big negative integers, and PAPI +** native events are big positive integers. +*/ + +typedef enum { + GPTLsync_mpi = 0, /* Synchronize before certain MPI calls (PMPI-mode only) */ + GPTLwall = 1, /* Collect wallclock stats (true) */ + GPTLcpu = 2, /* Collect CPU stats (false)*/ + GPTLabort_on_error = 3, /* Abort on failure (false) */ + GPTLoverhead = 4, /* Estimate overhead of underlying timing routine (true) */ + GPTLdepthlimit = 5, /* Only print timers this depth or less in the tree (inf) */ + GPTLverbose = 6, /* Verbose output (false) */ + GPTLnarrowprint = 7, /* Print PAPI and derived stats in 8 columns not 16 (true) */ + GPTLpercent = 9, /* Add a column for percent of first timer (false) */ + GPTLpersec = 10, /* Add a PAPI column that prints "per second" stats (true) */ + GPTLmultiplex = 11, /* Allow PAPI multiplexing (false) */ + GPTLdopr_preamble = 12, /* Print preamble info (true) */ + GPTLdopr_threadsort = 13, /* Print sorted thread stats (true) */ + GPTLdopr_multparent = 14, /* Print multiple parent info (true) */ + GPTLdopr_collision = 15, /* Print hastable collision info (true) */ + GPTLprint_method = 16, /* Tree print method: first parent, last parent + most frequent, or full tree (most frequent) */ + GPTLtablesize = 50, /* per-thread size of hash table (1024) */ + /* + ** These are derived counters based on PAPI counters. All default to false + */ + GPTL_IPC = 17, /* Instructions per cycle */ + GPTL_CI = 18, /* Computational intensity */ + GPTL_FPC = 19, /* FP ops per cycle */ + GPTL_FPI = 20, /* FP ops per instruction */ + GPTL_LSTPI = 21, /* Load-store instruction fraction */ + GPTL_DCMRT = 22, /* L1 miss rate (fraction) */ + GPTL_LSTPDCM = 23, /* Load-stores per L1 miss */ + GPTL_L2MRT = 24, /* L2 miss rate (fraction) */ + GPTL_LSTPL2M = 25, /* Load-stores per L2 miss */ + GPTL_L3MRT = 26, /* L3 read miss rate (fraction) */ + /* + ** New ACME option for GPTL + */ + GPTLprofile_ovhd = 27 /* Direct measurement of profiling overhead (false) */ +} Option; + +/* +** Underlying wallclock timer: optimize for best granularity with least overhead. +** These numbers need not be distinct from the above because these are passed +** to GPTLsetutr() and the above are passed to GPTLsetoption() +*/ + +typedef enum { + GPTLgettimeofday = 1, /* the default */ + GPTLnanotime = 2, /* only available on x86 */ + GPTLmpiwtime = 4, /* MPI_Wtime */ + GPTLclockgettime = 5, /* clock_gettime */ + GPTLpapitime = 6, /* only if PAPI is available */ + GPTLread_real_time = 3 /* AIX only */ +} Funcoption; + +/* +** How to report parent/child relationships at print time (for children with multiple parents) +*/ + +typedef enum { + GPTLfirst_parent = 1, /* first parent found */ + GPTLlast_parent = 2, /* last parent found */ + GPTLmost_frequent = 3, /* most frequent parent (default) */ + GPTLfull_tree = 4 /* complete call tree */ +} Method; + +/* +** Function prototypes +*/ + +#ifdef __cplusplus +extern "C" { +#endif + +extern int GPTLsetoption (const int, const int); +extern int GPTLinitialize (void); +extern int GPTLstart (const char *); +extern int GPTLstart_handle (const char *, void **); +extern int GPTLstartf (const char *, const int); +extern int GPTLstartf_handle (const char *, const int, void **); +extern int GPTLstop (const char *); +extern int GPTLstopf (const char *, const int); +extern int GPTLstop_handle (const char *, void **); +extern int GPTLstopf_handle (const char *, const int, void **); +extern int GPTLstamp (double *, double *, double *); +extern int GPTLpr_set_append (void); +extern int GPTLpr_query_append (void); +extern int GPTLpr_set_write (void); +extern int GPTLpr_query_write (void); +extern int GPTLpr (const int); +extern int GPTLpr_file (const char *); + +#ifdef HAVE_MPI +extern int GPTLpr_summary (MPI_Comm comm); +extern int GPTLpr_summary_file (MPI_Comm, const char *); +extern int GPTLbarrier (MPI_Comm comm, const char *); +#else +extern int GPTLpr_summary (int); +extern int GPTLpr_summary_file (int, const char *); +extern int GPTLbarrier (int, const char *); +#endif + +extern int GPTLreset (void); +extern int GPTLfinalize (void); +extern int GPTLget_memusage (int *, int *, int *, int *, int *); +extern int GPTLprint_memusage (const char *); +extern int GPTLenable (void); +extern int GPTLdisable (void); +extern int GPTLsetutr (const int); +extern int GPTLquery (const char *, int, int *, int *, double *, double *, double *, + long long *, const int); +extern int GPTLquerycounters (const char *, int, long long *); +extern int GPTLget_wallclock (const char *, int, double *); +extern int GPTLget_eventvalue (const char *, const char *, int, double *); +extern int GPTLget_nregions (int, int *); +extern int GPTLget_regionname (int, int, char *, int); +extern int GPTL_PAPIlibraryinit (void); +extern int GPTLevent_name_to_code (const char *, int *); +extern int GPTLevent_code_to_name (const int, char *); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/share/timing/gptl.inc b/share/timing/gptl.inc new file mode 100644 index 000000000000..688516993a72 --- /dev/null +++ b/share/timing/gptl.inc @@ -0,0 +1,170 @@ +! +! $Id: gptl.inc,v 1.44 2011-03-28 20:55:19 rosinski Exp $ +! +! Author: Jim Rosinski +! +! GPTL header file to be included in user code. Values match +! their counterparts in gptl.h. See that file or man pages +! or web-based documenation for descriptions of each value +! + integer GPTLsync_mpi + integer GPTLwall + integer GPTLcpu + integer GPTLabort_on_error + integer GPTLoverhead + integer GPTLdepthlimit + integer GPTLverbose + integer GPTLnarrowprint + integer GPTLpercent + integer GPTLpersec + integer GPTLmultiplex + integer GPTLdopr_preamble + integer GPTLdopr_threadsort + integer GPTLdopr_multparent + integer GPTLdopr_collision + integer GPTLprint_method + integer GPTLtablesize + + integer GPTL_IPC + integer GPTL_CI + integer GPTL_FPC + integer GPTL_FPI + integer GPTL_LSTPI + integer GPTL_DCMRT + integer GPTL_LSTPDCM + integer GPTL_L2MRT + integer GPTL_LSTPL2M + integer GPTL_L3MRT + + integer GPTLprofile_ovhd + + integer GPTLnanotime + integer GPTLmpiwtime + integer GPTLclockgettime + integer GPTLgettimeofday + integer GPTLpapitime + integer GPTLread_real_time + + integer GPTLfirst_parent + integer GPTLlast_parent + integer GPTLmost_frequent + integer GPTLfull_tree + + parameter (GPTLsync_mpi = 0) + parameter (GPTLwall = 1) + parameter (GPTLcpu = 2) + parameter (GPTLabort_on_error = 3) + parameter (GPTLoverhead = 4) + parameter (GPTLdepthlimit = 5) + parameter (GPTLverbose = 6) + parameter (GPTLnarrowprint = 7) + parameter (GPTLpercent = 9) + parameter (GPTLpersec = 10) + parameter (GPTLmultiplex = 11) + parameter (GPTLdopr_preamble = 12) + parameter (GPTLdopr_threadsort= 13) + parameter (GPTLdopr_multparent= 14) + parameter (GPTLdopr_collision = 15) + parameter (GPTLprint_method = 16) + parameter (GPTLtablesize = 50) + + parameter (GPTL_IPC = 17) + parameter (GPTL_CI = 18) + parameter (GPTL_FPC = 19) + parameter (GPTL_FPI = 20) + parameter (GPTL_LSTPI = 21) + parameter (GPTL_DCMRT = 22) + parameter (GPTL_LSTPDCM = 23) + parameter (GPTL_L2MRT = 24) + parameter (GPTL_LSTPL2M = 25) + parameter (GPTL_L3MRT = 26) + + parameter (GPTLprofile_ovhd = 27) + + parameter (GPTLgettimeofday = 1) + parameter (GPTLnanotime = 2) + parameter (GPTLmpiwtime = 4) + parameter (GPTLclockgettime = 5) + parameter (GPTLpapitime = 6) + parameter (GPTLread_real_time = 3) + + parameter (GPTLfirst_parent = 1) + parameter (GPTLlast_parent = 2) + parameter (GPTLmost_frequent = 3) + parameter (GPTLfull_tree = 4) + +! Externals + + integer gptlsetoption + integer gptlinitialize + integer gptlstart + integer gptlstart_handle + integer gptlstartf + integer gptlstartf_handle + integer gptlstop + integer gptlstop_handle + integer gptlstopf + integer gptlstopf_handle + integer gptlstamp + integer gptlpr_set_append + integer gptlpr_query_append + integer gptlpr_set_write + integer gptlpr_query_write + integer gptlpr + integer gptlpr_file + integer gptlpr_summary + integer gptlpr_summary_file + integer gptlbarrier + integer gptlreset + integer gptlfinalize + integer gptlget_memusage + integer gptlprint_memusage + integer gptlenable + integer gptldisable + integer gptlsetutr + integer gptlquery + integer gptlquerycounters + integer gptlget_wallclock + integer gptlget_eventvalue + integer gptlget_nregions + integer gptlget_regionname + integer gptl_papilibraryinit + integer gptlevent_name_to_code + integer gptlevent_code_to_name + + external gptlsetoption + external gptlinitialize + external gptlstart + external gptlstart_handle + external gptlstartf + external gptlstartf_handle + external gptlstop + external gptlstop_handle + external gptlstopf + external gptlstopf_handle + external gptlstamp + external gptlpr_set_append + external gptlpr_query_append + external gptlpr_set_write + external gptlpr_query_write + external gptlpr + external gptlpr_file + external gptlpr_summary + external gptlpr_summary_file + external gptlbarrier + external gptlreset + external gptlfinalize + external gptlget_memusage + external gptlprint_memusage + external gptlenable + external gptldisable + external gptlsetutr + external gptlquery + external gptlquerycounters + external gptlget_wallclock + external gptlget_eventvalue + external gptlget_nregions + external gptlget_regionname + external gptl_papilibraryinit + external gptlevent_name_to_code + external gptlevent_code_to_name diff --git a/share/timing/gptl_papi.c b/share/timing/gptl_papi.c new file mode 100644 index 000000000000..a8e42fd132ea --- /dev/null +++ b/share/timing/gptl_papi.c @@ -0,0 +1,1326 @@ +/* +** $Id: gptl_papi.c,v 1.79 2011-03-28 20:55:19 rosinski Exp $ +** +** Author: Jim Rosinski +** +** Contains routines which interface to PAPI library +*/ + +#include "private.h" +#include "gptl.h" + +#ifdef HAVE_PAPI + +#include +#include +#include +#include + +#if ( defined THREADED_OMP ) +#include +#elif ( defined THREADED_PTHREADS ) +#include +#endif + +/* Mapping of PAPI counters to short and long printed strings */ + +static const Entry papitable [] = { + {PAPI_L1_DCM, "PAPI_L1_DCM", "L1_DCM ", "L1_Dcache_miss ", "Level 1 data cache misses"}, + {PAPI_L1_ICM, "PAPI_L1_ICM", "L1_ICM ", "L1_Icache_miss ", "Level 1 instruction cache misses"}, + {PAPI_L2_DCM, "PAPI_L2_DCM", "L2_DCM ", "L2_Dcache_miss ", "Level 2 data cache misses"}, + {PAPI_L2_ICM, "PAPI_L2_ICM", "L2_ICM ", "L2_Icache_miss ", "Level 2 instruction cache misses"}, + {PAPI_L3_DCM, "PAPI_L3_DCM", "L3_DCM ", "L3_Dcache_miss ", "Level 3 data cache misses"}, + {PAPI_L3_ICM, "PAPI_L3_ICM", "L3_ICM ", "L3_Icache_miss ", "Level 3 instruction cache misses"}, + {PAPI_L1_TCM, "PAPI_L1_TCM", "L1_TCM ", "L1_cache_miss ", "Level 1 total cache misses"}, + {PAPI_L2_TCM, "PAPI_L2_TCM", "L2_TCM ", "L2_cache_miss ", "Level 2 total cache misses"}, + {PAPI_L3_TCM, "PAPI_L3_TCM", "L3_TCM ", "L3_cache_miss ", "Level 3 total cache misses"}, + {PAPI_CA_SNP, "PAPI_CA_SNP", "CA_SNP ", "Snoops ", "Snoops "}, + {PAPI_CA_SHR, "PAPI_CA_SHR", "CA_SHR ", "PAPI_CA_SHR ", "Request for shared cache line (SMP)"}, + {PAPI_CA_CLN, "PAPI_CA_CLN", "CA_CLN ", "PAPI_CA_CLN ", "Request for clean cache line (SMP)"}, + {PAPI_CA_INV, "PAPI_CA_INV", "CA_INV ", "PAPI_CA_INV ", "Request for cache line Invalidation (SMP)"}, + {PAPI_CA_ITV, "PAPI_CA_ITV", "CA_ITV ", "PAPI_CA_ITV ", "Request for cache line Intervention (SMP)"}, + {PAPI_L3_LDM, "PAPI_L3_LDM", "L3_LDM ", "L3_load_misses ", "Level 3 load misses"}, + {PAPI_L3_STM, "PAPI_L3_STM", "L3_STM ", "L3_store_misses ", "Level 3 store misses"}, + {PAPI_BRU_IDL,"PAPI_BRU_IDL","BRU_IDL ", "PAPI_BRU_IDL ", "Cycles branch units are idle"}, + {PAPI_FXU_IDL,"PAPI_FXU_IDL","FXU_IDL ", "PAPI_FXU_IDL ", "Cycles integer units are idle"}, + {PAPI_FPU_IDL,"PAPI_FPU_IDL","FPU_IDL ", "PAPI_FPU_IDL ", "Cycles floating point units are idle"}, + {PAPI_LSU_IDL,"PAPI_LSU_IDL","LSU_IDL ", "PAPI_LSU_IDL ", "Cycles load/store units are idle"}, + {PAPI_TLB_DM, "PAPI_TLB_DM" "TLB_DM ", "Data_TLB_misses ", "Data translation lookaside buffer misses"}, + {PAPI_TLB_IM, "PAPI_TLB_IM", "TLB_IM ", "Inst_TLB_misses ", "Instr translation lookaside buffer misses"}, + {PAPI_TLB_TL, "PAPI_TLB_TL", "TLB_TL ", "Tot_TLB_misses ", "Total translation lookaside buffer misses"}, + {PAPI_L1_LDM, "PAPI_L1_LDM", "L1_LDM ", "L1_load_misses ", "Level 1 load misses"}, + {PAPI_L1_STM, "PAPI_L1_STM", "L1_STM ", "L1_store_misses ", "Level 1 store misses"}, + {PAPI_L2_LDM, "PAPI_L2_LDM", "L2_LDM ", "L2_load_misses ", "Level 2 load misses"}, + {PAPI_L2_STM, "PAPI_L2_STM", "L2_STM ", "L2_store_misses ", "Level 2 store misses"}, + {PAPI_BTAC_M, "PAPI_BTAC_M", "BTAC_M ", "BTAC_miss ", "BTAC miss"}, + {PAPI_PRF_DM, "PAPI_PRF_DM", "PRF_DM ", "PAPI_PRF_DM ", "Prefetch data instruction caused a miss"}, + {PAPI_L3_DCH, "PAPI_L3_DCH", "L3_DCH ", "L3_DCache_Hit ", "Level 3 Data Cache Hit"}, + {PAPI_TLB_SD, "PAPI_TLB_SD", "TLB_SD ", "PAPI_TLB_SD ", "Xlation lookaside buffer shootdowns (SMP)"}, + {PAPI_CSR_FAL,"PAPI_CSR_FAL","CSR_FAL ", "PAPI_CSR_FAL ", "Failed store conditional instructions"}, + {PAPI_CSR_SUC,"PAPI_CSR_SUC","CSR_SUC ", "PAPI_CSR_SUC ", "Successful store conditional instructions"}, + {PAPI_CSR_TOT,"PAPI_CSR_TOT","CSR_TOT ", "PAPI_CSR_TOT ", "Total store conditional instructions"}, + {PAPI_MEM_SCY,"PAPI_MEM_SCY","MEM_SCY ", "Cyc_Stalled_Mem ", "Cycles Stalled Waiting for Memory Access"}, + {PAPI_MEM_RCY,"PAPI_MEM_RCY","MEM_RCY ", "Cyc_Stalled_MemR", "Cycles Stalled Waiting for Memory Read"}, + {PAPI_MEM_WCY,"PAPI_MEM_WCY","MEM_WCY ", "Cyc_Stalled_MemW", "Cycles Stalled Waiting for Memory Write"}, + {PAPI_STL_ICY,"PAPI_STL_ICY","STL_ICY ", "Cyc_no_InstrIss ", "Cycles with No Instruction Issue"}, + {PAPI_FUL_ICY,"PAPI_FUL_ICY","FUL_ICY ", "Cyc_Max_InstrIss", "Cycles with Maximum Instruction Issue"}, + {PAPI_STL_CCY,"PAPI_STL_CCY","STL_CCY ", "Cyc_No_InstrComp", "Cycles with No Instruction Completion"}, + {PAPI_FUL_CCY,"PAPI_FUL_CCY","FUL_CCY ", "Cyc_Max_InstComp", "Cycles with Maximum Instruction Completion"}, + {PAPI_HW_INT, "PAPI_HW_INT", "HW_INT ", "HW_interrupts ", "Hardware interrupts"}, + {PAPI_BR_UCN, "PAPI_BR_UCN", "BR_UCN ", "Uncond_br_instr ", "Unconditional branch instructions executed"}, + {PAPI_BR_CN, "PAPI_BR_CN", "BR_CN ", "Cond_br_instr_ex", "Conditional branch instructions executed"}, + {PAPI_BR_TKN, "PAPI_BR_TKN", "BR_TKN ", "Cond_br_instr_tk", "Conditional branch instructions taken"}, + {PAPI_BR_NTK, "PAPI_BR_NTK", "BR_NTK ", "Cond_br_instrNtk", "Conditional branch instructions not taken"}, + {PAPI_BR_MSP, "PAPI_BR_MSP", "BR_MSP ", "Cond_br_instrMPR", "Conditional branch instructions mispred"}, + {PAPI_BR_PRC, "PAPI_BR_PRC", "BR_PRC ", "Cond_br_instrCPR", "Conditional branch instructions corr. pred"}, + {PAPI_FMA_INS,"PAPI_FMA_INS","FMA_INS ", "FMA_instr_comp ", "FMA instructions completed"}, + {PAPI_TOT_IIS,"PAPI_TOT_IIS","TOT_IIS ", "Total_instr_iss ", "Total instructions issued"}, + {PAPI_TOT_INS,"PAPI_TOT_INS","TOT_INS ", "Total_instr_ex ", "Total instructions executed"}, + {PAPI_INT_INS,"PAPI_INT_INS","INT_INS ", "Int_instr_ex ", "Integer instructions executed"}, + {PAPI_FP_INS, "PAPI_FP_INS", "FP_INS ", "FP_instr_ex ", "Floating point instructions executed"}, + {PAPI_LD_INS, "PAPI_LD_INS", "LD_INS ", "Load_instr_ex ", "Load instructions executed"}, + {PAPI_SR_INS, "PAPI_SR_INS", "SR_INS ", "Store_instr_ex ", "Store instructions executed"}, + {PAPI_BR_INS, "PAPI_BR_INS", "BR_INS ", "br_instr_ex ", "Total branch instructions executed"}, + {PAPI_VEC_INS,"PAPI_VEC_INS","VEC_INS ", "Vec/SIMD_instrEx", "Vector/SIMD instructions executed"}, + {PAPI_RES_STL,"PAPI_RES_STL","RES_STL ", "Cyc_proc_stalled", "Cycles processor is stalled on resource"}, + {PAPI_FP_STAL,"PAPI_FP_STAL","FP_STAL ", "Cyc_any_FP_stall", "Cycles any FP units are stalled"}, + {PAPI_TOT_CYC,"PAPI_TOT_CYC","TOT_CYC ", "Total_cycles ", "Total cycles"}, + {PAPI_LST_INS,"PAPI_LST_INS","LST_INS ", "Tot_L/S_inst_ex ", "Total load/store inst. executed"}, + {PAPI_SYC_INS,"PAPI_SYC_INS","SYC_INS ", "Sync._inst._ex ", "Sync. inst. executed"}, + {PAPI_L1_DCH, "PAPI_L1_DCH", "L1_DCH ", "L1_D_Cache_Hit ", "L1 D Cache Hit"}, + {PAPI_L2_DCH, "PAPI_L2_DCH", "L2_DCH ", "L2_D_Cache_Hit ", "L2 D Cache Hit"}, + {PAPI_L1_DCA, "PAPI_L1_DCA", "L1_DCA ", "L1_D_Cache_Acc ", "L1 D Cache Access"}, + {PAPI_L2_DCA, "PAPI_L2_DCA", "L2_DCA ", "L2_D_Cache_Acc ", "L2 D Cache Access"}, + {PAPI_L3_DCA, "PAPI_L3_DCA", "L3_DCA ", "L3_D_Cache_Acc ", "L3 D Cache Access"}, + {PAPI_L1_DCR, "PAPI_L1_DCR", "L1_DCR ", "L1_D_Cache_Read ", "L1 D Cache Read"}, + {PAPI_L2_DCR, "PAPI_L2_DCR", "L2_DCR ", "L2_D_Cache_Read ", "L2 D Cache Read"}, + {PAPI_L3_DCR, "PAPI_L3_DCR", "L3_DCR ", "L3_D_Cache_Read ", "L3 D Cache Read"}, + {PAPI_L1_DCW, "PAPI_L1_DCW", "L1_DCW ", "L1_D_Cache_Write", "L1 D Cache Write"}, + {PAPI_L2_DCW, "PAPI_L2_DCW", "L2_DCW ", "L2_D_Cache_Write", "L2 D Cache Write"}, + {PAPI_L3_DCW, "PAPI_L3_DCW", "L3_DCW ", "L3_D_Cache_Write", "L3 D Cache Write"}, + {PAPI_L1_ICH, "PAPI_L1_ICH", "L1_ICH ", "L1_I_cache_hits ", "L1 instruction cache hits"}, + {PAPI_L2_ICH, "PAPI_L2_ICH", "L2_ICH ", "L2_I_cache_hits ", "L2 instruction cache hits"}, + {PAPI_L3_ICH, "PAPI_L3_ICH", "L3_ICH ", "L3_I_cache_hits ", "L3 instruction cache hits"}, + {PAPI_L1_ICA, "PAPI_L1_ICA", "L1_ICA ", "L1_I_cache_acc ", "L1 instruction cache accesses"}, + {PAPI_L2_ICA, "PAPI_L2_ICA", "L2_ICA ", "L2_I_cache_acc ", "L2 instruction cache accesses"}, + {PAPI_L3_ICA, "PAPI_L3_ICA", "L3_ICA ", "L3_I_cache_acc ", "L3 instruction cache accesses"}, + {PAPI_L1_ICR, "PAPI_L1_ICR", "L1_ICR ", "L1_I_cache_reads", "L1 instruction cache reads"}, + {PAPI_L2_ICR, "PAPI_L2_ICR", "L2_ICR ", "L2_I_cache_reads", "L2 instruction cache reads"}, + {PAPI_L3_ICR, "PAPI_L3_ICR", "L3_ICR ", "L3_I_cache_reads", "L3 instruction cache reads"}, + {PAPI_L1_ICW, "PAPI_L1_ICW", "L1_ICW ", "L1_I_cache_write", "L1 instruction cache writes"}, + {PAPI_L2_ICW, "PAPI_L2_ICW", "L2_ICW ", "L2_I_cache_write", "L2 instruction cache writes"}, + {PAPI_L3_ICW, "PAPI_L3_ICW", "L3_ICW ", "L3_I_cache_write", "L3 instruction cache writes"}, + {PAPI_L1_TCH, "PAPI_L1_TCH", "L1_TCH ", "L1_cache_hits ", "L1 total cache hits"}, + {PAPI_L2_TCH, "PAPI_L2_TCH", "L2_TCH ", "L2_cache_hits ", "L2 total cache hits"}, + {PAPI_L3_TCH, "PAPI_L3_TCH", "L3_TCH ", "L3_cache_hits ", "L3 total cache hits"}, + {PAPI_L1_TCA, "PAPI_L1_TCA", "L1_TCA ", "L1_cache_access ", "L1 total cache accesses"}, + {PAPI_L2_TCA, "PAPI_L2_TCA", "L2_TCA ", "L2_cache_access ", "L2 total cache accesses"}, + {PAPI_L3_TCA, "PAPI_L3_TCA", "L3_TCA ", "L3_cache_access ", "L3 total cache accesses"}, + {PAPI_L1_TCR, "PAPI_L1_TCR", "L1_TCR ", "L1_cache_reads ", "L1 total cache reads"}, + {PAPI_L2_TCR, "PAPI_L2_TCR", "L2_TCR ", "L2_cache_reads ", "L2 total cache reads"}, + {PAPI_L3_TCR, "PAPI_L3_TCR", "L3_TCR ", "L3_cache_reads ", "L3 total cache reads"}, + {PAPI_L1_TCW, "PAPI_L1_TCW", "L1_TCW ", "L1_cache_writes ", "L1 total cache writes"}, + {PAPI_L2_TCW, "PAPI_L2_TCW", "L2_TCW ", "L2_cache_writes ", "L2 total cache writes"}, + {PAPI_L3_TCW, "PAPI_L3_TCW", "L3_TCW ", "L3_cache_writes ", "L3 total cache writes"}, + {PAPI_FML_INS,"PAPI_FML_INS","FML_INS ", "FM_ins ", "FM ins"}, + {PAPI_FAD_INS,"PAPI_FAD_INS","FAD_INS ", "FA_ins ", "FA ins"}, + {PAPI_FDV_INS,"PAPI_FDV_INS","FDV_INS ", "FD_ins ", "FD ins"}, + {PAPI_FSQ_INS,"PAPI_FSQ_INS","FSQ_INS ", "FSq_ins ", "FSq ins"}, + {PAPI_FNV_INS,"PAPI_FNV_INS","FNV_INS ", "Finv_ins ", "Finv ins"}, + {PAPI_FP_OPS, "PAPI_FP_OPS", "FP_OPS ", "FP_ops_executed ", "Floating point operations executed"} +}; + +static const int npapientries = sizeof (papitable) / sizeof (Entry); +static int papieventlist[MAX_AUX]; /* list of PAPI events to be counted */ +static Pr_event pr_event[MAX_AUX]; /* list of events (PAPI or derived) */ + +/* Derived events */ +static const Entry derivedtable [] = { + {GPTL_IPC, "GPTL_IPC", "IPC ", "Instr_per_cycle ", "Instructions per cycle"}, + {GPTL_CI, "GPTL_CI", "CI ", "Comp_Intensity ", "Computational intensity"}, + {GPTL_FPC, "GPTL_FPC", "Flop/Cyc", "FP_Ops_per_cycle", "Floating point ops per cycle"}, + {GPTL_FPI, "GPTL_FPI", "Flop/Ins", "FP_Ops_per_instr", "Floating point ops per instruction"}, + {GPTL_LSTPI, "GPTL_LSTPI", "LST_frac", "LST_fraction ", "Load-store instruction fraction"}, + {GPTL_DCMRT, "GPTL_DCMRT", "DCMISRAT", "L1_Miss_Rate ", "L1 miss rate (fraction)"}, + {GPTL_LSTPDCM,"GPTL_LSTPDCM", "LSTPDCM ", "LST_per_L1_miss ", "Load-store instructions per L1 miss"}, + {GPTL_L2MRT, "GPTL_L2MRT", "L2MISRAT", "L2_Miss_Rate ", "L2 miss rate (fraction)"}, + {GPTL_LSTPL2M,"GPTL_LSTPL2M", "LSTPL2M ", "LST_per_L2_miss ", "Load-store instructions per L2 miss"}, + {GPTL_L3MRT, "GPTL_L3MRT", "L3MISRAT", "L3_Miss_Rate ", "L3 read miss rate (fraction)"} +}; +static const int nderivedentries = sizeof (derivedtable) / sizeof (Entry); + +static int npapievents = 0; /* number of PAPI events: initialize to 0 */ +static int nevents = 0; /* number of events: initialize to 0 */ +static int *EventSet; /* list of events to be counted by PAPI */ +static long_long **papicounters; /* counters returned from PAPI */ + +static const int BADCOUNT = -999999; /* Set counters to this when they are bad */ +static bool is_multiplexed = false; /* whether multiplexed (always start false)*/ +static bool narrowprint = true; /* only use 8 digits not 16 for counter prints */ +static bool persec = true; /* print PAPI stats per second */ +static bool enable_multiplexing = false; /* whether to try multiplexing */ +static bool verbose = false; /* output verbosity */ + +/* Function prototypes */ + +static int canenable (int); +static int canenable2 (int, int); +static int papievent_is_enabled (int); +static int already_enabled (int); +static int enable (int); +static int getderivedidx (int); + +/* +** GPTL_PAPIsetoption: enable or disable PAPI event defined by "counter". Called +** from GPTLsetoption. Since all events are off by default, val=false degenerates +** to a no-op. Coded this way to be consistent with the rest of GPTL +** +** Input args: +** counter: PAPI counter +** val: true or false for enable or disable +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTL_PAPIsetoption (const int counter, /* PAPI counter (or option) */ + const int val) /* true or false for enable or disable */ +{ + int n; /* loop index */ + int ret; /* return code */ + int numidx; /* numerator index */ + int idx; /* derived counter index */ + char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ + + /* + ** First, check for option which is not an actual counter + */ + + switch (counter) { + case GPTLverbose: + /* don't printf here--that'd duplicate what's in gptl.c */ + verbose = (bool) val; + return 0; + case GPTLmultiplex: + enable_multiplexing = (bool) val; + if (verbose) + printf ("GPTL_PAPIsetoption: boolean enable_multiplexing = %d\n", val); + return 0; + case GPTLnarrowprint: + narrowprint = (bool) val; + if (verbose) + printf ("GPTL_PAPIsetoption: boolean narrowprint = %d\n", val); + return 0; + case GPTLpersec: + persec = (bool) val; + if (verbose) + printf ("GPTL_PAPIsetoption: boolean persec = %d\n", val); + return 0; + default: + break; + } + + /* + ** If val is false, return an error if the event has already been enabled. + ** Otherwise just warn that attempting to disable a PAPI-based event + ** that has already been enabled doesn't work--for now it's just a no-op + */ + + if (! val) { + if (already_enabled (counter)) + return GPTLerror ("GPTL_PAPIsetoption: already enabled counter %d cannot be disabled\n", + counter); + else + if (verbose) + printf ("GPTL_PAPIsetoption: 'disable' %d currently is just a no-op\n", counter); + return 0; + } + + /* If the event has already been enabled for printing, exit */ + + if (already_enabled (counter)) + return GPTLerror ("GPTL_PAPIsetoption: counter %d has already been enabled\n", + counter); + + /* + ** Initialize PAPI if it hasn't already been done. + ** From here on down we can assume the intent is to enable (not disable) an option + */ + + if (GPTL_PAPIlibraryinit () < 0) + return GPTLerror ("GPTL_PAPIsetoption: PAPI library init error\n"); + + /* Ensure max nevents won't be exceeded */ + + if (nevents+1 > MAX_AUX) + return GPTLerror ("GPTL_PAPIsetoption: %d is too many events. Can be increased in private.h\n", + nevents+1); + + /* Check derived events */ + + switch (counter) { + case GPTL_IPC: + if ( ! canenable2 (PAPI_TOT_INS, PAPI_TOT_CYC)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_IPC unavailable\n"); + + idx = getderivedidx (GPTL_IPC); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_TOT_INS); + pr_event[nevents].denomidx = enable (PAPI_TOT_CYC); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_TOT_INS / PAPI_TOT_CYC\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + case GPTL_CI: + idx = getderivedidx (GPTL_CI); + if (canenable2 (PAPI_FP_OPS, PAPI_LST_INS)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_FP_OPS); + pr_event[nevents].denomidx = enable (PAPI_LST_INS); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_FP_OPS / PAPI_LST_INS\n", + pr_event[nevents].event.namestr); + } else if (canenable2 (PAPI_FP_OPS, PAPI_L1_DCA)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_FP_OPS); + pr_event[nevents].denomidx = enable (PAPI_L1_DCA); +#ifdef DEBUG + printf ("GPTL_PAPIsetoption: pr_event %d is derived and will be PAPI event %d / %d\n", + nevents, pr_event[nevents].numidx, pr_event[nevents].denomidx); +#endif + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_FP_OPS / PAPI_L1_DCA\n", + pr_event[nevents].event.namestr); + } else { + return GPTLerror ("GPTL_PAPIsetoption: GPTL_CI unavailable\n"); + } + ++nevents; + return 0; + case GPTL_FPC: + if ( ! canenable2 (PAPI_FP_OPS, PAPI_TOT_CYC)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_FPC unavailable\n"); + + idx = getderivedidx (GPTL_FPC); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_FP_OPS); + pr_event[nevents].denomidx = enable (PAPI_TOT_CYC); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_FP_OPS / PAPI_TOT_CYC\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + case GPTL_FPI: + if ( ! canenable2 (PAPI_FP_OPS, PAPI_TOT_INS)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_FPI unavailable\n"); + + idx = getderivedidx (GPTL_FPI); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_FP_OPS); + pr_event[nevents].denomidx = enable (PAPI_TOT_INS); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_FP_OPS / PAPI_TOT_INS\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + case GPTL_LSTPI: + idx = getderivedidx (GPTL_LSTPI); + if (canenable2 (PAPI_LST_INS, PAPI_TOT_INS)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_LST_INS); + pr_event[nevents].denomidx = enable (PAPI_TOT_INS); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_LST_INS / PAPI_TOT_INS\n", + pr_event[nevents].event.namestr); + } else if (canenable2 (PAPI_L1_DCA, PAPI_TOT_INS)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L1_DCA); + pr_event[nevents].denomidx = enable (PAPI_TOT_INS); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L1_DCA / PAPI_TOT_INS\n", + pr_event[nevents].event.namestr); + } else { + return GPTLerror ("GPTL_PAPIsetoption: GPTL_LSTPI unavailable\n"); + } + ++nevents; + return 0; + case GPTL_DCMRT: + if ( ! canenable2 (PAPI_L1_DCM, PAPI_L1_DCA)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_DCMRT unavailable\n"); + + idx = getderivedidx (GPTL_DCMRT); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L1_DCM); + pr_event[nevents].denomidx = enable (PAPI_L1_DCA); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L1_DCM / PAPI_L1_DCA\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + case GPTL_LSTPDCM: + idx = getderivedidx (GPTL_LSTPDCM); + if (canenable2 (PAPI_LST_INS, PAPI_L1_DCM)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_LST_INS); + pr_event[nevents].denomidx = enable (PAPI_L1_DCM); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_LST_INS / PAPI_L1_DCM\n", + pr_event[nevents].event.namestr); + } else if (canenable2 (PAPI_L1_DCA, PAPI_L1_DCM)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L1_DCA); + pr_event[nevents].denomidx = enable (PAPI_L1_DCM); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L1_DCA / PAPI_L1_DCM\n", + pr_event[nevents].event.namestr); + } else { + return GPTLerror ("GPTL_PAPIsetoption: GPTL_LSTPDCM unavailable\n"); + } + ++nevents; + return 0; + /* + ** For L2 counts, use TC* instead of DC* to avoid PAPI derived events + */ + case GPTL_L2MRT: + if ( ! canenable2 (PAPI_L2_TCM, PAPI_L2_TCA)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_L2MRT unavailable\n"); + + idx = getderivedidx (GPTL_L2MRT); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L2_TCM); + pr_event[nevents].denomidx = enable (PAPI_L2_TCA); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L2_TCM / PAPI_L2_TCA\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + case GPTL_LSTPL2M: + idx = getderivedidx (GPTL_LSTPL2M); + if (canenable2 (PAPI_LST_INS, PAPI_L2_TCM)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_LST_INS); + pr_event[nevents].denomidx = enable (PAPI_L2_TCM); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_LST_INS / PAPI_L2_TCM\n", + pr_event[nevents].event.namestr); + } else if (canenable2 (PAPI_L1_DCA, PAPI_L2_TCM)) { + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L1_DCA); + pr_event[nevents].denomidx = enable (PAPI_L2_TCM); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L1_DCA / PAPI_L2_TCM\n", + pr_event[nevents].event.namestr); + } else { + return GPTLerror ("GPTL_PAPIsetoption: GPTL_LSTPL2M unavailable\n"); + } + ++nevents; + return 0; + case GPTL_L3MRT: + if ( ! canenable2 (PAPI_L3_TCM, PAPI_L3_TCR)) + return GPTLerror ("GPTL_PAPIsetoption: GPTL_L3MRT unavailable\n"); + + idx = getderivedidx (GPTL_L3MRT); + pr_event[nevents].event = derivedtable[idx]; + pr_event[nevents].numidx = enable (PAPI_L3_TCM); + pr_event[nevents].denomidx = enable (PAPI_L3_TCR); + if (verbose) + printf ("GPTL_PAPIsetoption: enabling derived event %s = PAPI_L3_TCM / PAPI_L3_TCR\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + default: + break; + } + + /* Check PAPI presets */ + + for (n = 0; n < npapientries; n++) { + if (counter == papitable[n].counter) { + if ((numidx = papievent_is_enabled (counter)) >= 0) { + pr_event[nevents].event = papitable[n]; + pr_event[nevents].numidx = numidx; + pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ + } else if (canenable (counter)) { + pr_event[nevents].event = papitable[n]; + pr_event[nevents].numidx = enable (counter); + pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ + } else { + return GPTLerror ("GPTL_PAPIsetoption: Can't enable event \n", + papitable[n].longstr); + } + if (verbose) + printf ("GPTL_PAPIsetoption: enabling PAPI preset event %s\n", + pr_event[nevents].event.namestr); + ++nevents; + return 0; + } + } + + /* + ** Check native events last: If PAPI_event_code_to_name fails, give up + */ + + if ((ret = PAPI_event_code_to_name (counter, eventname)) != PAPI_OK) + return GPTLerror ("GPTL_PAPIsetoption: name not found for counter %d: PAPI_strerror: %s\n", + counter, PAPI_strerror (ret)); + + /* + ** A table with predefined names of various lengths does not exist for + ** native events. Just truncate eventname. + */ + + if ((numidx = papievent_is_enabled (counter)) >= 0) { + pr_event[nevents].event.counter = counter; + + pr_event[nevents].event.namestr = (char *) GPTLallocate (12+1); + strncpy (pr_event[nevents].event.namestr, eventname, 12); + pr_event[nevents].event.namestr[12] = '\0'; + + pr_event[nevents].event.str16 = (char *) GPTLallocate (16+1); + strncpy (pr_event[nevents].event.str16, eventname, 16); + pr_event[nevents].event.str16[16] = '\0'; + + pr_event[nevents].event.longstr = (char *) GPTLallocate (PAPI_MAX_STR_LEN); + strncpy (pr_event[nevents].event.longstr, eventname, PAPI_MAX_STR_LEN); + + pr_event[nevents].numidx = numidx; + pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ + } else if (canenable (counter)) { + pr_event[nevents].event.counter = counter; + + pr_event[nevents].event.namestr = (char *) GPTLallocate (12+1); + strncpy (pr_event[nevents].event.namestr, eventname, 12); + pr_event[nevents].event.namestr[12] = '\0'; + + pr_event[nevents].event.str16 = (char *) GPTLallocate (16+1); + strncpy (pr_event[nevents].event.str16, eventname, 16); + pr_event[nevents].event.str16[16] = '\0'; + + pr_event[nevents].event.longstr = (char *) GPTLallocate (PAPI_MAX_STR_LEN); + strncpy (pr_event[nevents].event.longstr, eventname, PAPI_MAX_STR_LEN); + + pr_event[nevents].numidx = enable (counter); + pr_event[nevents].denomidx = -1; /* flag says not derived (no denominator) */ + } else { + return GPTLerror ("GPTL_PAPIsetoption: Can't enable event %s\n", eventname); + } + + if (verbose) + printf ("GPTL_PAPIsetoption: enabling native event %s\n", pr_event[nevents].event.longstr); + + ++nevents; + return 0; +} + +/* +** canenable: determine whether a PAPI counter can be enabled +** +** Input args: +** counter: PAPI counter +** +** Return value: 0 (success) or non-zero (failure) +*/ + +int canenable (int counter) +{ + char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ + + if (npapievents+1 > MAX_AUX) + return false; + + if (PAPI_query_event (counter) != PAPI_OK) { + (void) PAPI_event_code_to_name (counter, eventname); + fprintf (stderr, "canenable: event %s not available on this arch\n", eventname); + return false; + } + + return true; +} + +/* +** canenable2: determine whether 2 PAPI counters can be enabled +** +** Input args: +** counter1: PAPI counter +** counter2: PAPI counter +** +** Return value: 0 (success) or non-zero (failure) +*/ + +int canenable2 (int counter1, int counter2) +{ + char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ + + if (npapievents+2 > MAX_AUX) + return false; + + if (PAPI_query_event (counter1) != PAPI_OK) { + (void) PAPI_event_code_to_name (counter1, eventname); + return false; + } + + if (PAPI_query_event (counter2) != PAPI_OK) { + (void) PAPI_event_code_to_name (counter2, eventname); + return false; + } + + return true; +} + +/* +** papievent_is_enabled: determine whether a PAPI counter has already been +** enabled. Used internally to keep track of PAPI counters enabled. A given +** PAPI counter may occur in the computation of multiple derived events, as +** well as output directly. E.g. PAPI_FP_OPS is used to compute +** computational intensity, and floating point ops per instruction. +** +** Input args: +** counter: PAPI counter +** +** Return value: index into papieventlist (success) or negative (not found) +*/ + +int papievent_is_enabled (int counter) +{ + int n; + + for (n = 0; n < npapievents; ++n) + if (papieventlist[n] == counter) + return n; + return -1; +} + +/* +** already_enabled: determine whether a PAPI-based event has already been +** enabled for printing. +** +** Input args: +** counter: PAPI or derived counter +** +** Return value: 1 (true) or 0 (false) +*/ + +int already_enabled (int counter) +{ + int n; + + for (n = 0; n < nevents; ++n) + if (pr_event[n].event.counter == counter) + return 1; + return 0; +} + +/* +** enable: enable a PAPI event. ASSUMES that canenable() has already determined +** that the event can be enabled. +** +** Input args: +** counter: PAPI counter +** +** Return value: index into papieventlist +*/ + +int enable (int counter) +{ + int n; + + /* If the event is already enabled, return its index */ + + for (n = 0; n < npapievents; ++n) { + if (papieventlist[n] == counter) { +#ifdef DEBUG + printf ("enable: PAPI event %d is %d\n", n, counter); +#endif + return n; + } + } + + /* New event */ + + papieventlist[npapievents++] = counter; + return npapievents-1; +} + +/* +** getderivedidx: find the table index of a derived counter +** +** Input args: +** counter: derived counter +** +** Return value: index into derivedtable (success) or GPTLerror (failure) +*/ + +int getderivedidx (int dcounter) +{ + int n; + + for (n = 0; n < nderivedentries; ++n) { + if (derivedtable[n].counter == dcounter) + return n; + } + return GPTLerror ("getderivedidx: failed to find derived counter %d\n", dcounter); +} + +/* +** GPTL_PAPIlibraryinit: Call PAPI_library_init if necessary +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTL_PAPIlibraryinit () +{ + int ret; + + if ((ret = PAPI_is_initialized ()) == PAPI_NOT_INITED) { + if ((ret = PAPI_library_init (PAPI_VER_CURRENT)) != PAPI_VER_CURRENT) { + fprintf (stderr, "GPTL_PAPIlibraryinit: ret=%d PAPI_VER_CURRENT=%d\n", + ret, (int) PAPI_VER_CURRENT); + return GPTLerror ("GPTL_PAPIlibraryinit: PAPI_library_init failure:%s\n", + PAPI_strerror (ret)); + } + } + return 0; +} + +/* +** GPTL_PAPIinitialize(): Initialize the PAPI interface. Called from GPTLinitialize. +** PAPI_library_init must be called before any other PAPI routines. +** PAPI_thread_init is called subsequently if threading is enabled. +** Finally, allocate space for PAPI counters and start them. +** +** Input args: +** maxthreads: number of threads +** +** Return value: 0 (success) or GPTLerror or -1 (failure) +*/ + +int GPTL_PAPIinitialize (const int maxthreads, /* number of threads */ + const bool verbose_flag, /* output verbosity */ + int *nevents_out, /* nevents needed by gptl.c */ + Entry *pr_event_out) /* events needed by gptl.c */ +{ + int ret; /* return code */ + int n; /* loop index */ + int t; /* thread index */ + + verbose = verbose_flag; + + if (maxthreads < 1) + return GPTLerror ("GPTL_PAPIinitialize: maxthreads = %d\n", maxthreads); + + /* Ensure that PAPI_library_init has already been called */ + + if ((ret = GPTL_PAPIlibraryinit ()) < 0) + return GPTLerror ("GPTL_PAPIinitialize: GPTL_PAPIlibraryinit failure\n"); + + /* PAPI_thread_init needs to be called if threading enabled */ + +#if ( defined THREADED_OMP ) + if (PAPI_thread_init ((unsigned long (*)(void)) (omp_get_thread_num)) != PAPI_OK) + return GPTLerror ("GPTL_PAPIinitialize: PAPI_thread_init failure\n"); +#elif ( defined THREADED_PTHREADS ) + if (PAPI_thread_init ((unsigned long (*)(void)) (pthread_self)) != PAPI_OK) + return GPTLerror ("GPTL_PAPIinitialize: PAPI_thread_init failure\n"); +#endif + + /* allocate and initialize static local space */ + + EventSet = (int *) GPTLallocate (maxthreads * sizeof (int)); + papicounters = (long_long **) GPTLallocate (maxthreads * sizeof (long_long *)); + + for (t = 0; t < maxthreads; t++) { + EventSet[t] = PAPI_NULL; + papicounters[t] = (long_long *) GPTLallocate (MAX_AUX * sizeof (long_long)); + } + + *nevents_out = nevents; + for (n = 0; n < nevents; ++n) { + pr_event_out[n].counter = pr_event[n].event.counter; + pr_event_out[n].namestr = pr_event[n].event.namestr; + pr_event_out[n].str8 = pr_event[n].event.str8; + pr_event_out[n].str16 = pr_event[n].event.str16; + pr_event_out[n].longstr = pr_event[n].event.longstr; + } + return 0; +} + +/* +** GPTLcreate_and_start_events: Create and start the PAPI eventset. +** Threaded routine to create the "event set" (PAPI terminology) and start +** the counters. This is only done once, and is called from get_thread_num +** for the first time for the thread. +** +** Input args: +** t: thread number +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLcreate_and_start_events (const int t) /* thread number */ +{ + int ret; /* return code */ + int n; /* loop index over events */ + char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ + + /* Create the event set */ + + if ((ret = PAPI_create_eventset (&EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: thread %d failure creating eventset: %s\n", + t, PAPI_strerror (ret)); + + if (verbose) + printf ("GPTLcreate_and_start_events: successfully created eventset for thread %d\n", t); + + /* Add requested events to the event set */ + + for (n = 0; n < npapievents; n++) { + if ((ret = PAPI_add_event (EventSet[t], papieventlist[n])) != PAPI_OK) { + if (verbose) { + fprintf (stderr, "%s\n", PAPI_strerror (ret)); + ret = PAPI_event_code_to_name (papieventlist[n], eventname); + fprintf (stderr, "GPTLcreate_and_start_events: failure adding event:%s\n", + eventname); + } + + if (enable_multiplexing) { + if (verbose) + printf ("Trying multiplexing...\n"); + is_multiplexed = true; + break; + } else + return GPTLerror ("enable_multiplexing is false: giving up\n"); + } + } + + if (is_multiplexed) { + + /* Cleanup the eventset for multiplexing */ + + if ((ret = PAPI_cleanup_eventset (EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: %s\n", PAPI_strerror (ret)); + + if ((ret = PAPI_destroy_eventset (&EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: %s\n", PAPI_strerror (ret)); + + if ((ret = PAPI_create_eventset (&EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: failure creating eventset: %s\n", + PAPI_strerror (ret)); + + if ((ret = PAPI_multiplex_init ()) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: failure from PAPI_multiplex_init%s\n", + PAPI_strerror (ret)); + + if ((ret = PAPI_set_multiplex (EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: failure from PAPI_set_multiplex: %s\n", + PAPI_strerror (ret)); + + for (n = 0; n < npapievents; n++) { + if ((ret = PAPI_add_event (EventSet[t], papieventlist[n])) != PAPI_OK) { + ret = PAPI_event_code_to_name (papieventlist[n], eventname); + return GPTLerror ("GPTLcreate_and_start_events: failure adding event:%s\n" + " Error was: %s\n", eventname, PAPI_strerror (ret)); + } + } + } + + /* Start the event set. It will only be read from now on--never stopped */ + + if ((ret = PAPI_start (EventSet[t])) != PAPI_OK) + return GPTLerror ("GPTLcreate_and_start_events: failed to start event set: %s\n", + PAPI_strerror (ret)); + + return 0; +} + +/* +** GPTL_PAPIstart: Start the PAPI counters (actually they are just read). +** Called from GPTLstart. +** +** Input args: +** t: thread number +** +** Output args: +** aux: struct containing the counters +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTL_PAPIstart (const int t, /* thread number */ + Papistats *aux) /* struct containing PAPI stats */ +{ + int ret; /* return code from PAPI lib calls */ + int n; /* loop index */ + + /* If no events are to be counted just return */ + + if (npapievents == 0) + return 0; + + /* Read the counters */ + + if ((ret = PAPI_read (EventSet[t], papicounters[t])) != PAPI_OK) + return GPTLerror ("GPTL_PAPIstart: %s\n", PAPI_strerror (ret)); + + /* + ** Store the counter values. When GPTL_PAPIstop is called, the counters + ** will again be read, and differenced with the values saved here. + */ + + for (n = 0; n < npapievents; n++) + aux->last[n] = papicounters[t][n]; + + return 0; +} + +/* +** GPTL_PAPIstop: Stop the PAPI counters (actually they are just read). +** Called from GPTLstop. +** +** Input args: +** t: thread number +** +** Input/output args: +** aux: struct containing the counters +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTL_PAPIstop (const int t, /* thread number */ + Papistats *aux) /* struct containing PAPI stats */ +{ + int ret; /* return code from PAPI lib calls */ + int n; /* loop index */ + long_long delta; /* change in counters from previous read */ + + /* If no events are to be counted just return */ + + if (npapievents == 0) + return 0; + + /* Read the counters */ + + if ((ret = PAPI_read (EventSet[t], papicounters[t])) != PAPI_OK) + return GPTLerror ("GPTL_PAPIstop: %s\n", PAPI_strerror (ret)); + + /* + ** Accumulate the difference since timer start in aux. + ** Negative accumulation can happen when multiplexing is enabled, so don't + ** set count to BADCOUNT in that case. + */ + + for (n = 0; n < npapievents; n++) { +#ifdef DEBUG + printf ("GPTL_PAPIstop: event %d counter value is %ld\n", n, (long) papicounters[t][n]); +#endif + delta = papicounters[t][n] - aux->last[n]; + if ( ! is_multiplexed && delta < 0) + aux->accum[n] = BADCOUNT; + else + aux->accum[n] += delta; + } + return 0; +} + +/* +** GPTL_PAPIprstr: Print the descriptive string for all enabled PAPI events. +** Called from GPTLpr. +** +** Input args: +** fp: file descriptor +*/ + +void GPTL_PAPIprstr (FILE *fp) +{ + int n; + + if (narrowprint) { + for (n = 0; n < nevents; n++) { + fprintf (fp, "%8.8s ", pr_event[n].event.str8); + + /* Test on < 0 says it's a PAPI preset */ + + if (persec && pr_event[n].event.counter < 0) + fprintf (fp, "e6_/_sec "); + } + } else { + for (n = 0; n < nevents; n++) { + fprintf (fp, "%16.16s ", pr_event[n].event.str16); + + /* Test on < 0 says it's a PAPI preset */ + + if (persec && pr_event[n].event.counter < 0) + fprintf (fp, "e6_/_sec "); + } + } +} + +/* +** GPTL_PAPIpr: Print PAPI counter values for all enabled events, including +** derived events. Called from GPTLpr. +** +** Input args: +** fp: file descriptor +** aux: struct containing the counters +*/ + +void GPTL_PAPIpr (FILE *fp, /* file descriptor to write to */ + const Papistats *aux, /* stats to write */ + const int t, /* thread number */ + const int count, /* number of invocations */ + const double wcsec) /* wallclock time (sec) */ +{ + const char *shortintfmt = "%8ld "; + const char *longintfmt = "%16ld "; + const char *shortfloatfmt = "%8.2e "; + const char *longfloatfmt = "%16.10e "; + const char *intfmt; /* integer format */ + const char *floatfmt; /* floating point format */ + + int n; /* loop index */ + int numidx; /* index pointer to appropriated (derived) numerator */ + int denomidx; /* index pointer to appropriated (derived) denominator */ + double val; /* value to be printed */ + + intfmt = narrowprint ? shortintfmt : longintfmt; + floatfmt = narrowprint ? shortfloatfmt : longfloatfmt; + + for (n = 0; n < nevents; n++) { + numidx = pr_event[n].numidx; + if (pr_event[n].denomidx > -1) { /* derived event */ + denomidx = pr_event[n].denomidx; + +#ifdef DEBUG + printf ("GPTL_PAPIpr: derived event: numidx=%d denomidx=%d values = %ld %ld\n", + numidx, denomidx, (long) aux->accum[numidx], (long) aux->accum[denomidx]); +#endif + /* Protect against divide by zero */ + + if (aux->accum[denomidx] > 0) + val = (double) aux->accum[numidx] / (double) aux->accum[denomidx]; + else + val = 0.; + fprintf (fp, floatfmt, val); + + } else { /* Raw PAPI event */ + +#ifdef DEBUG + printf ("GPTL_PAPIpr: raw event: numidx=%d value = %ld\n", + numidx, (long) aux->accum[numidx]); +#endif + if (aux->accum[numidx] < PRTHRESH) + fprintf (fp, intfmt, (long) aux->accum[numidx]); + else + fprintf (fp, floatfmt, (double) aux->accum[numidx]); + + if (persec) { + if (wcsec > 0.) + fprintf (fp, "%8.2f ", aux->accum[numidx] * 1.e-6 / wcsec); + else + fprintf (fp, "%8.2f ", 0.); + } + } + } +} + +/* +** GPTL_PAPIprintenabled: Print list of enabled timers +** +** Input args: +** fp: file descriptor +*/ + +void GPTL_PAPIprintenabled (FILE *fp) +{ + int n, nn; + PAPI_event_info_t info; /* returned from PAPI_get_event_info */ + char eventname[PAPI_MAX_STR_LEN]; /* returned from PAPI_event_code_to_name */ + + if (nevents > 0) { + fprintf (fp, "Description of printed events (PAPI and derived):\n"); + for (n = 0; n < nevents; n++) { + if (strncmp (pr_event[n].event.namestr, "GPTL", 4) == 0) { + fprintf (fp, " %s: %s\n", pr_event[n].event.namestr, pr_event[n].event.longstr); + } else { + nn = pr_event[n].event.counter; + if (PAPI_get_event_info (nn, &info) == PAPI_OK) { + fprintf (fp, " %s\n", info.short_descr); + fprintf (fp, " %s\n", info.note); + } + } + } + fprintf (fp, "\n"); + + fprintf (fp, "PAPI events enabled (including those required for derived events):\n"); + for (n = 0; n < npapievents; n++) + if (PAPI_event_code_to_name (papieventlist[n], eventname) == PAPI_OK) + fprintf (fp, " %s\n", eventname); + fprintf (fp, "\n"); + } +} + +/* +** GPTL_PAPIadd: Accumulate PAPI counters. Called from add. +** +** Input/Output args: +** auxout: auxout = auxout + auxin +** +** Input args: +** auxin: counters to be summed into auxout +*/ + +void GPTL_PAPIadd (Papistats *auxout, /* output struct */ + const Papistats *auxin) /* input struct */ +{ + int n; + + for (n = 0; n < npapievents; n++) + if (auxin->accum[n] == BADCOUNT || auxout->accum[n] == BADCOUNT) + auxout->accum[n] = BADCOUNT; + else + auxout->accum[n] += auxin->accum[n]; +} + +/* +** GPTL_PAPIfinalize: finalization routine must be called from single-threaded +** region. Free all malloc'd space +*/ + +void GPTL_PAPIfinalize (int maxthreads) +{ + int t; /* thread index */ + int ret; /* return code */ + + for (t = 0; t < maxthreads; t++) { + ret = PAPI_stop (EventSet[t], papicounters[t]); + free (papicounters[t]); + ret = PAPI_cleanup_eventset (EventSet[t]); + ret = PAPI_destroy_eventset (&EventSet[t]); + } + + free (EventSet); + free (papicounters); + + /* Reset initial values */ + + npapievents = 0; + nevents = 0; + is_multiplexed = false; + narrowprint = true; + persec = true; + enable_multiplexing = false; + verbose = false; +} + +/* +** GPTL_PAPIquery: return current PAPI counter info. Return into a long for best +** compatibility possibilities with Fortran. +** +** Input args: +** aux: struct containing the counters +** ncounters: max number of counters to return +** +** Output args: +** papicounters_out: current value of PAPI counters +*/ + +void GPTL_PAPIquery (const Papistats *aux, + long long *papicounters_out, + int ncounters) +{ + int n; + + if (ncounters > 0) { + for (n = 0; n < ncounters && n < npapievents; n++) { + papicounters_out[n] = (long long) aux->accum[n]; + } + } +} + +/* +** GPTL_PAPIget_eventvalue: return current value for an enabled event. +** +** Input args: +** eventname: event name to check (whether derived or raw PAPI counter) +** aux: struct containing the counter(s) for the event +** +** Output args: +** value: current value of the event +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTL_PAPIget_eventvalue (const char *eventname, + const Papistats *aux, + double *value) +{ + int n; /* loop index through enabled events */ + int numidx; /* numerator index into papicounters */ + int denomidx; /* denominator index into papicounters */ + + for (n = 0; n < nevents; ++n) { + if (STRMATCH (eventname, pr_event[n].event.namestr)) { + numidx = pr_event[n].numidx; + if (pr_event[n].denomidx > -1) { /* derived event */ + denomidx = pr_event[n].denomidx; + if (aux->accum[denomidx] > 0) /* protect against divide by zero */ + *value = (double) aux->accum[numidx] / (double) aux->accum[denomidx]; + else + *value = 0.; + } else { /* Raw PAPI event */ + *value = (double) aux->accum[numidx]; + } + break; + } + } + if (n == nevents) + return GPTLerror ("GPTL_PAPIget_eventvalue: event %s not enabled\n", eventname); + return 0; +} + +/* +** GPTL_PAPIis_multiplexed: return status of whether events are being multiplexed +*/ + +bool GPTL_PAPIis_multiplexed () +{ + return is_multiplexed; +} + +/* +** The following functions are publicly available +*/ + +void read_counters100 () +{ + int i; + int ret; + long_long counters[MAX_AUX]; + + for (i = 0; i < 10; ++i) { + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + ret = PAPI_read (EventSet[0], counters); + } + return; +} + +/* +** GPTLevent_name_to_code: convert a string to a PAPI code +** or derived event code. +** +** Input arguments: +** arg: string to convert +** +** Output arguments: +** code: PAPI or GPTL derived code +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLevent_name_to_code (const char *name, int *code) +{ + int ret; /* return code */ + int n; /* loop over derived entries */ + + /* + ** First check derived events + */ + + for (n = 0; n < nderivedentries; ++n) { + if (STRMATCH (name, derivedtable[n].namestr)) { + *code = derivedtable[n].counter; + return 0; + } + } + + /* + ** Next check PAPI events--note that PAPI must be initialized before the + ** name_to_code function can be invoked. + */ + + if ((ret = GPTL_PAPIlibraryinit ()) < 0) + return GPTLerror ("GPTL_event_name_to_code: GPTL_PAPIlibraryinit failure\n"); + + if ((PAPI_event_name_to_code ((char *) name, code)) != PAPI_OK) + return GPTLerror ("GPTL_event_name_to_code: PAPI_event_name_to_code failure\n"); + + return 0; +} + +/* +** GPTLevent_code_to_name: convert a string to a PAPI code +** or derived event code. +** +** Input arguments: +** code: event code (PAPI or derived) +** +** Output arguments: +** name: string corresponding to code +** +** Return value: 0 (success) or GPTLerror (failure) +*/ + +int GPTLevent_code_to_name (const int code, char *name) +{ + int ret; /* return code */ + int n; /* loop over derived entries */ + + /* + ** First check derived events + */ + + for (n = 0; n < nderivedentries; ++n) { + if (code == derivedtable[n].counter) { + strcpy (name, derivedtable[n].namestr); + return 0; + } + } + + /* + ** Next check PAPI events--note that PAPI must be initialized before the + ** code_to_name function can be invoked. + */ + + if ((ret = GPTL_PAPIlibraryinit ()) < 0) + return GPTLerror ("GPTL_event_code_to_name: GPTL_PAPIlibraryinit failure\n"); + + if (PAPI_event_code_to_name (code, name) != PAPI_OK) + return GPTLerror ("GPTL_event_code_to_name: PAPI_event_code_to_name failure\n"); + + return 0; +} + +int GPTLget_npapievents (void) +{ + return npapievents; +} + +#else + +/* +** HAVE_PAPI not defined branch: "Should not be called" entry points for public routines +*/ + +int GPTL_PAPIlibraryinit () +{ + return GPTLerror ("GPTL_PAPIlibraryinit: PAPI not enabled\n"); +} + +int GPTLevent_name_to_code (const char *name, int *code) +{ + return GPTLerror ("GPTLevent_name_to_code: PAPI not enabled\n"); +} + +int GPTLevent_code_to_name (int code, char *name) +{ + return GPTLerror ("GPTLevent_code_to_name: PAPI not enabled\n"); +} + +#endif /* HAVE_PAPI */ + diff --git a/share/timing/perf_mod.F90 b/share/timing/perf_mod.F90 new file mode 100644 index 000000000000..92ee57ce7c59 --- /dev/null +++ b/share/timing/perf_mod.F90 @@ -0,0 +1,1623 @@ +module perf_mod + +!----------------------------------------------------------------------- +! +! Purpose: This module is responsible for controlling the performance +! timer logic. +! +! Author: P. Worley, January 2007 +! +! $Id$ +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!- Uses ---------------------------------------------------------------- +!----------------------------------------------------------------------- + +#ifndef USE_CSM_SHARE + use perf_utils +#else + use shr_sys_mod, only: shr_sys_abort + use shr_kind_mod, only: SHR_KIND_CS, SHR_KIND_CM, SHR_KIND_CX, & + SHR_KIND_R8, SHR_KIND_I8 + use shr_mpi_mod, only: shr_mpi_barrier, shr_mpi_bcast + use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit + use namelist_utils, only: find_group_name +#endif + +!----------------------------------------------------------------------- +!- module boilerplate -------------------------------------------------- +!----------------------------------------------------------------------- + implicit none + private ! Make the default access private +#include + save + +!----------------------------------------------------------------------- +! Public interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + public t_initf + public t_setLogUnit + public t_getLogUnit + public t_profile_onf + public t_barrier_onf + public t_single_filef + public t_set_prefixf + public t_unset_prefixf + public t_stampf + public t_startf + public t_stopf + public t_enablef + public t_disablef + public t_adj_detailf + public t_barrierf + public t_prf + public t_finalizef + +!----------------------------------------------------------------------- +! Private interfaces (local) ------------------------------------------- +!----------------------------------------------------------------------- + private perf_defaultopts + private perf_setopts + private papi_defaultopts + private papi_setopts + +!----------------------------------------------------------------------- +!- include statements -------------------------------------------------- +!----------------------------------------------------------------------- +#include "gptl.inc" + +!----------------------------------------------------------------------- +! Private data --------------------------------------------------------- +!----------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! perf_mod options + !---------------------------------------------------------------------------- + integer, parameter :: def_p_logunit = 6 ! default + integer, private :: p_logunit = def_p_logunit + ! unit number for log output + + logical, parameter :: def_timing_initialized = .false. ! default + logical, private :: timing_initialized = def_timing_initialized + ! flag indicating whether timing library has + ! been initialized + + logical, parameter :: def_timing_disable = .false. ! default + logical, private :: timing_disable = def_timing_disable + ! flag indicating whether timers are disabled + + logical, parameter :: def_timing_barrier = .false. ! default + logical, private :: timing_barrier = def_timing_barrier + ! flag indicating whether the mpi_barrier in + ! t_barrierf should be called + + integer, parameter :: def_timer_depth_limit = 99999 ! default + integer, private :: timer_depth_limit = def_timer_depth_limit + ! integer indicating maximum number of levels of + ! timer nesting + + integer, parameter :: def_timing_detail_limit = 1 ! default + integer, private :: timing_detail_limit = def_timing_detail_limit + ! integer indicating maximum detail level to + ! profile + + integer, parameter :: init_timing_disable_depth = 0 ! init + integer, private :: timing_disable_depth = init_timing_disable_depth + ! integer indicating depth of t_disablef calls + + integer, parameter :: init_timing_detail = 0 ! init + integer, private :: cur_timing_detail = init_timing_detail + ! current timing detail level + + logical, parameter :: def_perf_single_file = .false. ! default + logical, private :: perf_single_file = def_perf_single_file + ! flag indicating whether the performance timer + ! output should be written to a single file + ! (per component communicator) or to a + ! separate file for each process + + integer, parameter :: def_perf_outpe_num = 0 ! default + integer, private :: perf_outpe_num = def_perf_outpe_num + ! maximum number of processes writing out + ! timing data (for this component communicator) + + integer, parameter :: def_perf_outpe_stride = 1 ! default + integer, private :: perf_outpe_stride = def_perf_outpe_stride + ! separation between process ids for processes + ! that are writing out timing data + ! (for this component communicator) + + logical, parameter :: def_perf_global_stats = .true. ! default + logical, private :: perf_global_stats = def_perf_global_stats + ! collect and print out global performance statistics + ! (for this component communicator) + + logical, parameter :: def_perf_ovhd_measurement = .false. ! default + logical, private :: perf_ovhd_measurement = def_perf_ovhd_measurement + ! measure overhead of profiling directly + + logical, parameter :: def_perf_add_detail = .false. ! default + logical, private :: perf_add_detail = def_perf_add_detail + ! flag indicating whether to prefix the + ! timer name with the current detail level. + ! This requires that even t_startf/t_stopf + ! calls do not cross detail level changes + + character(len=SHR_KIND_CS), private :: event_prefix + ! current prefix for all event names. + ! Default defined to be blank via + ! prefix_len_def + integer, parameter :: prefix_len_def = 0 ! default + integer, private :: prefix_len = prefix_len_def + ! For convenience, contains len_trim of + ! event_prefix, if set. + +#ifdef HAVE_MPI + integer, parameter :: def_perf_timer = GPTLmpiwtime ! default +#else +#ifdef HAVE_NANOTIME + integer, parameter :: def_perf_timer = GPTLnanotime ! default +#else +#ifdef CPRIBM + integer,parameter :: def_perf_timer = GPTLread_real_time +#else + integer,parameter :: def_perf_timer = GPTLgettimeofday +#endif +#endif +#endif + + + integer, private :: perf_timer = def_perf_timer ! default + ! integer indicating which timer to use + ! (as defined in gptl.inc) + +#ifdef HAVE_PAPI + logical, parameter :: def_perf_papi_enable = .false. ! default +#else + logical, parameter :: def_perf_papi_enable = .false. ! default +#endif + logical, private :: perf_papi_enable = def_perf_papi_enable + ! flag indicating whether the PAPI namelist + ! should be read and HW performance counters + ! used in profiling + + ! PAPI counter ids + integer, parameter :: PAPI_NULL = -1 + + integer, parameter :: def_papi_ctr1 = PAPI_NULL ! default + integer, private :: papi_ctr1 = def_papi_ctr1 + + integer, parameter :: def_papi_ctr2 = PAPI_NULL ! default + integer, private :: papi_ctr2 = def_papi_ctr2 + + integer, parameter :: def_papi_ctr3 = PAPI_NULL ! default + integer, private :: papi_ctr3 = def_papi_ctr3 + + integer, parameter :: def_papi_ctr4 = PAPI_NULL ! default + integer, private :: papi_ctr4 = def_papi_ctr4 + +!======================================================================= +contains +!======================================================================= + +! +!======================================================================== +! + subroutine t_getLogUnit(LogUnit) +!----------------------------------------------------------------------- +! Purpose: Get log unit number. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer(SHR_KIND_IN), intent(OUT) :: LogUnit ! Unit number for log output +!----------------------------------------------------------------------- + + LogUnit = p_logunit + + return + end subroutine t_getLogUnit +! +!======================================================================== +! + subroutine t_setLogUnit(LogUnit) +!----------------------------------------------------------------------- +! Purpose: Set log unit number. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer(SHR_KIND_IN), intent(IN) :: LogUnit ! Unit number for log output +!----------------------------------------------------------------------- + + p_logunit = LogUnit +#ifndef USE_CSM_SHARE + call perfutils_setunit(p_logunit) +#endif + + return + end subroutine t_setLogUnit +! +!======================================================================== +! + subroutine perf_defaultopts(timing_disable_out, & + perf_timer_out, & + timer_depth_limit_out, & + timing_detail_limit_out, & + timing_barrier_out, & + perf_outpe_num_out, & + perf_outpe_stride_out, & + perf_single_file_out, & + perf_global_stats_out, & + perf_papi_enable_out, & + perf_ovhd_measurement_out, & + perf_add_detail_out ) +!----------------------------------------------------------------------- +! Purpose: Return default runtime options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! timers disable/enable option + logical, intent(out), optional :: timing_disable_out + ! performance timer option + integer, intent(out), optional :: perf_timer_out + ! timer depth limit option + integer, intent(out), optional :: timer_depth_limit_out + ! timer detail limit option + integer, intent(out), optional :: timing_detail_limit_out + ! timing barrier enable/disable option + logical, intent(out), optional :: timing_barrier_out + ! number of processes writing out timing data + integer, intent(out), optional :: perf_outpe_num_out + ! separation between process ids for processes that are writing out timing data + integer, intent(out), optional :: perf_outpe_stride_out + ! timing single / multple output file option + logical, intent(out), optional :: perf_single_file_out + ! collect and output global performance statistics option + logical, intent(out), optional :: perf_global_stats_out + ! calling PAPI to read HW performance counters option + logical, intent(out), optional :: perf_papi_enable_out + ! measure overhead of profiling directly + logical, intent(out), optional :: perf_ovhd_measurement_out + ! prefix timer name with current detail level + logical, intent(out), optional :: perf_add_detail_out +!----------------------------------------------------------------------- + if ( present(timing_disable_out) ) then + timing_disable_out = def_timing_disable + endif + if ( present(perf_timer_out) ) then + perf_timer_out = def_perf_timer + endif + if ( present(timer_depth_limit_out) ) then + timer_depth_limit_out = def_timer_depth_limit + endif + if ( present(timing_detail_limit_out) ) then + timing_detail_limit_out = def_timing_detail_limit + endif + if ( present(timing_barrier_out) ) then + timing_barrier_out = def_timing_barrier + endif + if ( present(perf_outpe_num_out) ) then + perf_outpe_num_out = def_perf_outpe_num + endif + if ( present(perf_outpe_stride_out) ) then + perf_outpe_stride_out = def_perf_outpe_stride + endif + if ( present(perf_single_file_out) ) then + perf_single_file_out = def_perf_single_file + endif + if ( present(perf_global_stats_out) ) then + perf_global_stats_out = def_perf_global_stats + endif + if ( present(perf_papi_enable_out) ) then + perf_papi_enable_out = def_perf_papi_enable + endif + if ( present(perf_ovhd_measurement_out) ) then + perf_ovhd_measurement_out = def_perf_ovhd_measurement + endif + if ( present(perf_add_detail_out) ) then + perf_add_detail_out = def_perf_add_detail + endif +! + return + end subroutine perf_defaultopts +! +!======================================================================== +! + subroutine perf_setopts(mastertask, & + LogPrint, & + timing_disable_in, & + perf_timer_in, & + timer_depth_limit_in, & + timing_detail_limit_in, & + timing_barrier_in, & + perf_outpe_num_in, & + perf_outpe_stride_in, & + perf_single_file_in, & + perf_global_stats_in, & + perf_papi_enable_in, & + perf_ovhd_measurement_in, & + perf_add_detail_in ) +!----------------------------------------------------------------------- +! Purpose: Set runtime options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments---------------------------- +! + ! master process? + logical, intent(in) :: mastertask + ! Print out to log file? + logical, intent(IN) :: LogPrint + ! timers disable/enable option + logical, intent(in), optional :: timing_disable_in + ! performance timer option + integer, intent(in), optional :: perf_timer_in + ! timer depth limit option + integer, intent(in), optional :: timer_depth_limit_in + ! timer detail limit option + integer, intent(in), optional :: timing_detail_limit_in + ! timing barrier enable/disable option + logical, intent(in), optional :: timing_barrier_in + ! number of processes writing out timing data + integer, intent(in), optional :: perf_outpe_num_in + ! separation between process ids for processes that are writing out timing data + integer, intent(in), optional :: perf_outpe_stride_in + ! timing single / multple output file option + logical, intent(in), optional :: perf_single_file_in + ! collect and output global performance statistics option + logical, intent(in), optional :: perf_global_stats_in + ! calling PAPI to read HW performance counters option + logical, intent(in), optional :: perf_papi_enable_in + ! measure overhead of profiling directly + logical, intent(in), optional :: perf_ovhd_measurement_in + ! prefix timer name with current detail level + logical, intent(in), optional :: perf_add_detail_in +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! error return +!----------------------------------------------------------------------- + if ( .not. timing_initialized ) then + + if ( present(timing_disable_in) ) then + timing_disable = timing_disable_in + if (timing_disable) then + ierr = GPTLdisable() + else + ierr = GPTLenable() + endif + endif + if ( present(perf_timer_in) ) then + if ((perf_timer_in .eq. GPTLgettimeofday) .or. & + (perf_timer_in .eq. GPTLnanotime) .or. & + (perf_timer_in .eq. GPTLread_real_time) .or. & + (perf_timer_in .eq. GPTLmpiwtime) .or. & + (perf_timer_in .eq. GPTLclockgettime) .or. & + (perf_timer_in .eq. GPTLpapitime)) then + perf_timer = perf_timer_in + else + if (mastertask) then + write(p_logunit,*) 'PERF_SETOPTS: illegal timer requested=',& + perf_timer_in, '. Request ignored.' + endif + endif + endif + if ( present(timer_depth_limit_in) ) then + timer_depth_limit = timer_depth_limit_in + endif + if ( present(timing_detail_limit_in) ) then + timing_detail_limit = timing_detail_limit_in + endif + if ( present(timing_barrier_in) ) then + timing_barrier = timing_barrier_in + endif + if ( present(perf_outpe_num_in) ) then + perf_outpe_num = perf_outpe_num_in + endif + if ( present(perf_outpe_stride_in) ) then + perf_outpe_stride = perf_outpe_stride_in + endif + if ( present(perf_single_file_in) ) then + perf_single_file = perf_single_file_in + endif + if ( present(perf_global_stats_in) ) then + perf_global_stats = perf_global_stats_in + endif + if ( present(perf_papi_enable_in) ) then +#ifdef HAVE_PAPI + perf_papi_enable = perf_papi_enable_in +#else + if (perf_papi_enable_in) then + if (mastertask) then + write(p_logunit,*) 'PERF_SETOPTS: PAPI library not linked in. ',& + 'Request to enable PAPI ignored.' + endif + endif + perf_papi_enable = .false. +#endif + endif + if ( present(perf_ovhd_measurement_in) ) then + perf_ovhd_measurement = perf_ovhd_measurement_in + endif + if ( present(perf_add_detail_in) ) then + perf_add_detail = perf_add_detail_in + endif +! + if (mastertask .and. LogPrint) then + write(p_logunit,*) '(t_initf) Using profile_disable= ', timing_disable + write(p_logunit,*) '(t_initf) profile_timer= ', perf_timer + write(p_logunit,*) '(t_initf) profile_depth_limit= ', timer_depth_limit + write(p_logunit,*) '(t_initf) profile_detail_limit= ', timing_detail_limit + write(p_logunit,*) '(t_initf) profile_barrier= ', timing_barrier + write(p_logunit,*) '(t_initf) profile_outpe_num= ', perf_outpe_num + write(p_logunit,*) '(t_initf) profile_outpe_stride= ', perf_outpe_stride + write(p_logunit,*) '(t_initf) profile_single_file= ', perf_single_file + write(p_logunit,*) '(t_initf) profile_global_stats= ', perf_global_stats + write(p_logunit,*) '(t_initf) profile_ovhd_measurement=', perf_ovhd_measurement + write(p_logunit,*) '(t_initf) profile_add_detail= ', perf_add_detail + write(p_logunit,*) '(t_initf) profile_papi_enable= ', perf_papi_enable + endif +! +#ifdef DEBUG + else + write(p_logunit,*) 'PERF_SETOPTS: timing library already initialized. Request ignored.' +#endif + endif +! + return + end subroutine perf_setopts + +! +!======================================================================== +! + subroutine papi_defaultopts(papi_ctr1_out, & + papi_ctr2_out, & + papi_ctr3_out, & + papi_ctr4_out ) +!----------------------------------------------------------------------- +! Purpose: Return default runtime PAPI counter options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! PAPI counter option #1 + integer, intent(out), optional :: papi_ctr1_out + ! PAPI counter option #2 + integer, intent(out), optional :: papi_ctr2_out + ! PAPI counter option #3 + integer, intent(out), optional :: papi_ctr3_out + ! PAPI counter option #4 + integer, intent(out), optional :: papi_ctr4_out +!----------------------------------------------------------------------- + if ( present(papi_ctr1_out) ) then + papi_ctr1_out = def_papi_ctr1 + endif + if ( present(papi_ctr2_out) ) then + papi_ctr2_out = def_papi_ctr2 + endif + if ( present(papi_ctr3_out) ) then + papi_ctr3_out = def_papi_ctr3 + endif + if ( present(papi_ctr4_out) ) then + papi_ctr4_out = def_papi_ctr4 + endif +! + return + end subroutine papi_defaultopts +! +!======================================================================== +! + subroutine papi_setopts(papi_ctr1_in, & + papi_ctr2_in, & + papi_ctr3_in, & + papi_ctr4_in ) +!----------------------------------------------------------------------- +! Purpose: Set runtime PAPI counter options +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments---------------------------- +! + ! performance counter option + integer, intent(in), optional :: papi_ctr1_in + ! performance counter option + integer, intent(in), optional :: papi_ctr2_in + ! performance counter option + integer, intent(in), optional :: papi_ctr3_in + ! performance counter option + integer, intent(in), optional :: papi_ctr4_in +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! error return +!----------------------------------------------------------------------- + if ( .not. timing_initialized ) then + + if ( present(papi_ctr1_in) ) then + if (papi_ctr1_in < 0) then + papi_ctr1 = papi_ctr1_in + else + papi_ctr1 = PAPI_NULL + endif + endif + if ( present(papi_ctr2_in) ) then + if (papi_ctr2_in < 0) then + papi_ctr2 = papi_ctr2_in + else + papi_ctr2 = PAPI_NULL + endif + endif + if ( present(papi_ctr3_in) ) then + if (papi_ctr3_in < 0) then + papi_ctr3 = papi_ctr3_in + else + papi_ctr3 = PAPI_NULL + endif + endif + if ( present(papi_ctr4_in) ) then + if (papi_ctr4_in < 0) then + papi_ctr4 = papi_ctr4_in + else + papi_ctr4 = PAPI_NULL + endif + endif +! +#ifdef DEBUG + else + write(p_logunit,*) 'PAPI_SETOPTS: timing library already initialized. Request ignored.' +#endif + endif +! + return + end subroutine papi_setopts +! +!======================================================================== +! + logical function t_profile_onf() +!----------------------------------------------------------------------- +! Purpose: Return flag indicating whether profiling is currently active. +! Part of workaround to implement FVbarrierclock before +! communicators exposed in Pilgrim. Does not check level of +! event nesting. +! Author: P. Worley +!----------------------------------------------------------------------- + + if ((.not. timing_initialized) .or. & + (timing_disable_depth > 0)) then + t_profile_onf = .false. + else + t_profile_onf = .true. + endif + + end function t_profile_onf +! +!======================================================================== +! + logical function t_barrier_onf() +!----------------------------------------------------------------------- +! Purpose: Return timing_barrier. Part of workaround to implement +! FVbarrierclock before communicators exposed in Pilgrim. +! Author: P. Worley +!----------------------------------------------------------------------- + + t_barrier_onf = timing_barrier + + end function t_barrier_onf +! +!======================================================================== +! + logical function t_single_filef() +!----------------------------------------------------------------------- +! Purpose: Return perf_single_file. Used to control output of other +! performance data, only spmdstats currently. +! Author: P. Worley +!----------------------------------------------------------------------- + + t_single_filef = perf_single_file + + end function t_single_filef +! +!======================================================================== +! + subroutine t_set_prefixf(prefix_string) +!----------------------------------------------------------------------- +! Purpose: Set prefix for subsequent time event names. +! Ignored in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name prefix + character(len=*), intent(in) :: prefix_string +! +!---------------------------Local workspace----------------------------- +! + integer i ! loop index +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + prefix_len = min(SHR_KIND_CS,len_trim(prefix_string)) + if (prefix_len > 0) then + event_prefix(1:prefix_len) = prefix_string(1:prefix_len) + endif + + end subroutine t_set_prefixf +! +!======================================================================== +! + subroutine t_unset_prefixf() +!----------------------------------------------------------------------- +! Purpose: Unset prefix for subsequent time event names. +! Ignored in threaded regions. +! Author: P. Worley +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + prefix_len = 0 + + end subroutine t_unset_prefixf +! +!======================================================================== +! + subroutine t_stampf(wall, usr, sys) +!----------------------------------------------------------------------- +! Purpose: Record wallclock, user, and system times (seconds). +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Output arguments----------------------------- +! + real(shr_kind_r8), intent(out) :: wall ! wallclock time + real(shr_kind_r8), intent(out) :: usr ! user time + real(shr_kind_r8), intent(out) :: sys ! system time +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!----------------------------------------------------------------------- +! + if ((.not. timing_initialized) .or. & + (timing_disable_depth > 0)) then + wall = 0.0 + usr = 0.0 + sys = 0.0 + else + ierr = GPTLstamp(wall, usr, sys) + endif + + return + end subroutine t_stampf +! +!======================================================================== +! + subroutine t_startf(event, handle) +!----------------------------------------------------------------------- +! Purpose: Start an event timer +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name + character(len=*), intent(in) :: event +! +!---------------------------Input/Output arguments---------------------- +! + ! GPTL event handle + integer, optional :: handle +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + integer str_length, i ! support for adding prefix + character(len=2) cdetail ! char variable for detail +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return + + if ((perf_add_detail) .AND. (cur_timing_detail < 100)) then + + write(cdetail,'(i2.2)') cur_timing_detail + if (prefix_len > 0) then + str_length = min(SHR_KIND_CM-prefix_len-3,len_trim(event)) + ierr = GPTLstart( & + cdetail//"_"//event_prefix(1:prefix_len)//event(1:str_length)) + else + str_length = min(SHR_KIND_CM-3,len_trim(event)) + ierr = GPTLstart(cdetail//"_"//event(1:str_length)) + endif + + else + + if (prefix_len > 0) then + str_length = min(SHR_KIND_CM-prefix_len,len_trim(event)) + ierr = GPTLstart(event_prefix(1:prefix_len)//event(1:str_length)) + else + ierr = GPTLstart(trim(event)) + endif + +!pw if ( present (handle) ) then +!pw ierr = GPTLstart_handle(event, handle) +!pw else +!pw ierr = GPTLstart(event) +!pw endif + + endif + + return + end subroutine t_startf +! +!======================================================================== +! + subroutine t_stopf(event, handle) +!----------------------------------------------------------------------- +! Purpose: Stop an event timer +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer event name + character(len=*), intent(in) :: event +! +!---------------------------Input/Output arguments---------------------- +! + ! GPTL event handle + integer, optional :: handle +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return + integer str_length, i, plen ! support for adding prefix + character(len=2) cdetail ! char variable for detail +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return + + if ((perf_add_detail) .AND. (cur_timing_detail < 100)) then + + write(cdetail,'(i2.2)') cur_timing_detail + if (prefix_len > 0) then + str_length = min(SHR_KIND_CM-prefix_len-3,len_trim(event)) + ierr = GPTLstop( & + cdetail//"_"//event_prefix(1:prefix_len)//event(1:str_length)) + else + str_length = min(SHR_KIND_CM-3,len_trim(event)) + ierr = GPTLstop(cdetail//"_"//event(1:str_length)) + endif + + else + + if (prefix_len > 0) then + str_length = min(SHR_KIND_CM-prefix_len,len_trim(event)) + ierr = GPTLstop(event_prefix(1:prefix_len)//event(1:str_length)) + else + ierr = GPTLstop(trim(event)) + endif + +!pw if ( present (handle) ) then +!pw ierr = GPTLstop_handle(event, handle) +!pw else +!pw ierr = GPTLstop(event) +!pw endif + + endif + + return + end subroutine t_stopf +! +!======================================================================== +! + subroutine t_enablef() +!----------------------------------------------------------------------- +! Purpose: Enable t_startf, t_stopf, t_stampf, and t_barrierf. Ignored +! in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + if (timing_disable_depth > 0) then + if (timing_disable_depth .eq. 1) then + ierr = GPTLenable() + endif + timing_disable_depth = timing_disable_depth - 1 + endif + + return + end subroutine t_enablef +! +!======================================================================== +! + subroutine t_disablef() +!----------------------------------------------------------------------- +! Purpose: Disable t_startf, t_stopf, t_stampf, and t_barrierf. Ignored +! in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + + if (timing_disable_depth .eq. 0) then + ierr = GPTLdisable() + endif + timing_disable_depth = timing_disable_depth + 1 + + return + end subroutine t_disablef +! +!======================================================================== +! + subroutine t_adj_detailf(detail_adjustment) +!----------------------------------------------------------------------- +! Purpose: Modify current detail level. Ignored in threaded regions. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer, intent(in) :: detail_adjustment ! user defined increase or + ! decrease in detail level +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + +! using disable/enable to implement timing_detail logic so also control +! direct GPTL calls (such as occur in Trilinos library) + if ((cur_timing_detail <= timing_detail_limit) .and. & + (cur_timing_detail + detail_adjustment > timing_detail_limit)) then + call t_disablef() + elseif ((cur_timing_detail > timing_detail_limit) .and. & + (cur_timing_detail + detail_adjustment <= timing_detail_limit)) then + call t_enablef() + endif + + cur_timing_detail = cur_timing_detail + detail_adjustment + + return + end subroutine t_adj_detailf +! +!======================================================================== +! + subroutine t_barrierf(event, mpicom) +!----------------------------------------------------------------------- +! Purpose: Call (and time) mpi_barrier. Ignored inside OpenMP +! threaded regions. Note that barrier executed even if +! event not recorded because of level of timer event nesting. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- + ! mpi communicator id + integer, intent(in), optional :: mpicom + ! performance timer event name + character(len=*), intent(in), optional :: event +! +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!---------------------------Externals----------------------------------- +! +#if ( defined _OPENMP ) + logical omp_in_parallel + external omp_in_parallel +#endif +! +!----------------------------------------------------------------------- +! + if (timing_barrier) then + +#if ( defined _OPENMP ) + if (omp_in_parallel()) return +#endif + if (.not. timing_initialized) return + if (timing_disable_depth > 0) return + + if ( present (event) ) then + call t_startf(event) + endif + + if ( present (mpicom) ) then + call shr_mpi_barrier(mpicom, 'T_BARRIERF: bad mpi communicator') + else + call shr_mpi_barrier(MPI_COMM_WORLD, 'T_BARRIERF: bad mpi communicator') + endif + + if ( present (event) ) then + call t_stopf(event) + endif + + endif + + return + end subroutine t_barrierf +! +!======================================================================== +! + subroutine t_prf(filename, mpicom, num_outpe, stride_outpe, & + single_file, global_stats, output_thispe) +!----------------------------------------------------------------------- +! Purpose: Write out performance timer data +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + ! performance timer output file name + character(len=*), intent(in), optional :: filename + ! mpi communicator id + integer, intent(in), optional :: mpicom + ! maximum number of processes writing out timing data + integer, intent(in), optional :: num_outpe + ! separation between process ids for processes writing out data + integer, intent(in), optional :: stride_outpe + ! enable/disable the writing of data to a single file + logical, intent(in), optional :: single_file + ! enable/disable the collection of global statistics + logical, intent(in), optional :: global_stats + ! output timing data for this process + logical, intent(in), optional :: output_thispe +! +!---------------------------Local workspace----------------------------- +! + logical one_file ! flag indicting whether to write + ! all data to a single file + logical glb_stats ! flag indicting whether to compute + ! global statistics + logical pr_write ! flag indicating whether the current + ! GPTL output mode is write + logical write_data ! flag indicating whether this process + ! should output its timing data + integer i ! loop index + integer mpicom2 ! local copy of MPI communicator + integer me ! communicator local process id + integer npes ! local communicator group size + integer gme ! global process id + integer ierr ! MPI error return + integer outpe_num ! max number of processes writing out + ! timing data (excluding output_thispe) + integer outpe_stride ! separation between process ids for + ! processes writing out timing data + integer max_outpe ! max process id for processes + ! writing out timing data + integer signal ! send/recv variable for single + ! output file logic + integer str_length ! string length + integer unitn ! file unit number + integer cme_adj ! length of filename suffix + integer status (MPI_STATUS_SIZE) ! Status of message + character(len=7) cme ! string representation of process id + character(len=SHR_KIND_CX+14) fname ! timing output filename +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + + call t_startf("t_prf") +!$OMP MASTER + call mpi_comm_rank(MPI_COMM_WORLD, gme, ierr) + if ( present(mpicom) ) then + mpicom2 = mpicom + call mpi_comm_size(mpicom2, npes, ierr) + if (ierr .eq. MPI_ERR_COMM) then + call shr_sys_abort('T_PRF: bad mpi communicator') + endif + call mpi_comm_rank(mpicom2, me, ierr) + else + call mpi_comm_size(MPI_COMM_WORLD, npes, ierr) + mpicom2 = MPI_COMM_WORLD + me = gme + endif + + do i=1,SHR_KIND_CX+14 + fname(i:i) = " " + enddo + + unitn = shr_file_getUnit() + + ! determine what the current output mode is (append or write) + if (GPTLpr_query_write() == 1) then + pr_write = .true. + ierr = GPTLpr_set_append() + else + pr_write=.false. + endif + + ! Determine whether to write all data to a single fie + if (present(single_file)) then + one_file = single_file + else + one_file = perf_single_file + endif + + ! Determine whether to compute global statistics + if (present(global_stats)) then + glb_stats = global_stats + else + glb_stats = perf_global_stats + endif + + ! Determine which processes are writing out timing data + write_data = .false. + + if (present(num_outpe)) then + if (num_outpe < 0) then + outpe_num = npes + else + outpe_num = num_outpe + endif + else + if (perf_outpe_num < 0) then + outpe_num = npes + else + outpe_num = perf_outpe_num + endif + endif + + if (present(stride_outpe)) then + if (stride_outpe < 1) then + outpe_stride = 1 + else + outpe_stride = stride_outpe + endif + else + if (perf_outpe_stride < 1) then + outpe_stride = 1 + else + outpe_stride = perf_outpe_stride + endif + endif + + max_outpe = min(outpe_num*outpe_stride, npes) - 1 + + if ((mod(me, outpe_stride) .eq. 0) .and. (me .le. max_outpe)) & + write_data = .true. + + if (present(output_thispe)) then + write_data = output_thispe + endif + + ! If a single timing output file, take turns writing to it. + if (one_file) then + + if ( present(filename) ) then + str_length = min(SHR_KIND_CX,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + fname(1:10) = "timing_all" + endif + + signal = 0 + if (me .eq. 0) then + + if (glb_stats) then + open( unitn, file=trim(fname), status='UNKNOWN' ) + write( unitn, 100) npes + 100 format(/,"***** GLOBAL STATISTICS (",I6," MPI TASKS) *****",/) + close( unitn ) + + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + endif + + if (write_data) then + if (glb_stats) then + open( unitn, file=trim(fname), status='OLD', position='APPEND' ) + else + open( unitn, file=trim(fname), status='UNKNOWN' ) + endif + + write( unitn, 101) me, gme + 101 format(/,"************ PROCESS ",I6," (",I6,") ************",/) + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + else + + if (glb_stats) then + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + endif + + call mpi_recv (signal, 1, mpi_integer, me-1, me-1, mpicom2, status, ierr) + if (ierr /= mpi_success) then + write(p_logunit,*) 'T_PRF: mpi_recv failed ierr=',ierr + call shr_sys_abort() + end if + + if (write_data) then + open( unitn, file=trim(fname), status='OLD', position='APPEND' ) + write( unitn, 101) me, gme + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + endif + + if (me+1 < npes) & + call mpi_send (signal, 1, mpi_integer, me+1, me, mpicom2, ierr) + + else + + if (glb_stats) then + if ( present(filename) ) then + str_length = min(SHR_KIND_CX-6,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + str_length = 6 + fname(1:10) = "timing" + endif + fname(str_length+1:str_length+6) = '_stats' + + if (me .eq. 0) then + open( unitn, file=trim(fname), status='UNKNOWN' ) + write( unitn, 100) npes + close( unitn ) + endif + + ierr = GPTLpr_summary_file(mpicom2, trim(fname)) + fname(str_length+1:str_length+6) = ' ' + endif + + if (write_data) then + if (npes .le. 10) then + write(cme,'(i1.1)') me + cme_adj = 2 + elseif (npes .le. 100) then + write(cme,'(i2.2)') me + cme_adj = 3 + elseif (npes .le. 1000) then + write(cme,'(i3.3)') me + cme_adj = 4 + elseif (npes .le. 10000) then + write(cme,'(i4.4)') me + cme_adj = 5 + elseif (npes .le. 100000) then + write(cme,'(i5.5)') me + cme_adj = 6 + else + write(cme,'(i6.6)') me + cme_adj = 7 + endif + + if ( present(filename) ) then + str_length = min(SHR_KIND_CX-cme_adj,len_trim(filename)) + fname(1:str_length) = filename(1:str_length) + else + str_length = 6 + fname(1:10) = "timing" + endif + fname(str_length+1:str_length+1) = '.' + fname(str_length+2:str_length+cme_adj) = cme + + open( unitn, file=trim(fname), status='UNKNOWN' ) + write( unitn, 101) me, gme + close( unitn ) + + ierr = GPTLpr_file(trim(fname)) + endif + + endif + + call shr_file_freeUnit( unitn ) + + ! reset GPTL output mode + if (pr_write) then + ierr = GPTLpr_set_write() + endif + +!$OMP END MASTER + call t_stopf("t_prf") + + return + end subroutine t_prf +! +!======================================================================== +! + subroutine t_initf(NLFilename, LogPrint, LogUnit, mpicom, MasterTask, & + MaxThreads) +!----------------------------------------------------------------------- +! Purpose: Set default values of runtime timing options +! before namelists prof_inparm and papi_inparm are read, +! read namelists (and broadcast, if SPMD), +! then initialize timing library. +! Author: P. Worley (based on shr_inputinfo_mod and runtime_opts) +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + character(len=*), intent(IN) :: NLFilename ! Name-list filename + logical, optional, intent(IN) :: LogPrint ! If print out to log file + integer, optional, intent(IN) :: LogUnit ! Unit number for log output + integer, optional, intent(IN) :: mpicom ! MPI communicator + logical, optional, intent(IN) :: MasterTask ! If MPI master task + integer, optional, intent(IN) :: MaxThreads ! maximum number of threads + ! used by components +! +!---------------------------Local workspace----------------------------- +! + character(len=*), parameter :: subname = '(T_INITF) ' + logical :: MasterTask2 ! If MPI master task + logical :: LogPrint2 ! If print to log + + integer me ! communicator local process id + integer ierr ! error return + integer unitn ! file unit number + integer papi_ctr1_id ! PAPI counter id + integer papi_ctr2_id ! PAPI counter id + integer papi_ctr3_id ! PAPI counter id + integer papi_ctr4_id ! PAPI counter id +! +!---------------------------Namelists ---------------------------------- +! + logical profile_disable + logical profile_barrier + logical profile_single_file + logical profile_global_stats + integer profile_depth_limit + integer profile_detail_limit + integer profile_outpe_num + integer profile_outpe_stride + integer profile_timer + logical profile_papi_enable + logical profile_ovhd_measurement + logical profile_add_detail + namelist /prof_inparm/ profile_disable, profile_barrier, & + profile_single_file, profile_global_stats, & + profile_depth_limit, & + profile_detail_limit, profile_outpe_num, & + profile_outpe_stride, profile_timer, & + profile_papi_enable, profile_ovhd_measurement, & + profile_add_detail + + character(len=16) papi_ctr1_str + character(len=16) papi_ctr2_str + character(len=16) papi_ctr3_str + character(len=16) papi_ctr4_str + namelist /papi_inparm/ papi_ctr1_str, papi_ctr2_str, & + papi_ctr3_str, papi_ctr4_str +!----------------------------------------------------------------------- + if ( timing_initialized ) then +#ifdef DEBUG + write(p_logunit,*) 'T_INITF: timing library already initialized. Request ignored.' +#endif + return + endif + +!$OMP MASTER + if ( present(LogUnit) ) then + call t_setLogUnit(LogUnit) + else + call t_setLogUnit(def_p_logunit) + endif + + if ( present(MasterTask) .and. present(mpicom) )then + call mpi_comm_rank(mpicom, me, ierr) + if (ierr .eq. MPI_ERR_COMM) then + call shr_sys_abort('T_INITF: bad mpi communicator') + endif + if (me .eq. 0) then + MasterTask2 = .true. + else + MasterTask2 = .false. + endif + else + MasterTask2 = .true. + end if + + if ( present(LogPrint) ) then + LogPrint2 = LogPrint + else + LogPrint2 = .true. + endif + + ! Set PERF defaults, then override with user-specified input + call perf_defaultopts(timing_disable_out=profile_disable, & + perf_timer_out=profile_timer, & + timer_depth_limit_out=profile_depth_limit, & + timing_detail_limit_out=profile_detail_limit, & + timing_barrier_out=profile_barrier, & + perf_outpe_num_out = profile_outpe_num, & + perf_outpe_stride_out = profile_outpe_stride, & + perf_single_file_out=profile_single_file, & + perf_global_stats_out=profile_global_stats, & + perf_papi_enable_out=profile_papi_enable, & + perf_ovhd_measurement_out=profile_ovhd_measurement, & + perf_add_detail_out=profile_add_detail ) + if ( MasterTask2 ) then + + ! Read in the prof_inparm namelist from NLFilename if it exists + + write(p_logunit,*) '(t_initf) Read in prof_inparm namelist from: '//trim(NLFilename) + unitn = shr_file_getUnit() + + ierr = 1 + open( unitn, file=trim(NLFilename), status='old', iostat=ierr ) + if (ierr .eq. 0) then + + ! Look for prof_inparm group name in the input file. + ! If found, leave the file positioned at that namelist group. + call find_group_name(unitn, 'prof_inparm', status=ierr) + + if (ierr == 0) then ! found prof_inparm + read(unitn, nml=prof_inparm, iostat=ierr) + if (ierr /= 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' error condition for prof_inparm' ) + end if + end if + + close(unitn) + + endif + call shr_file_freeUnit( unitn ) + + endif + + ! This logic assumes that there will be only one MasterTask + ! per communicator, and that this MasterTask is process 0. + if ( present(MasterTask) .and. present(mpicom) )then + call shr_mpi_bcast( profile_disable, MPICom ) + call shr_mpi_bcast( profile_barrier, MPICom ) + call shr_mpi_bcast( profile_single_file, MPICom ) + call shr_mpi_bcast( profile_global_stats, MPICom ) + call shr_mpi_bcast( profile_papi_enable, MPICom ) + call shr_mpi_bcast( profile_ovhd_measurement, MPICom ) + call shr_mpi_bcast( profile_add_detail, MPICom ) + call shr_mpi_bcast( profile_depth_limit, MPICom ) + call shr_mpi_bcast( profile_detail_limit, MPICom ) + call shr_mpi_bcast( profile_outpe_num, MPICom ) + call shr_mpi_bcast( profile_outpe_stride, MPICom ) + call shr_mpi_bcast( profile_timer, MPICom ) + end if + call perf_setopts (MasterTask2, LogPrint2, & + timing_disable_in=profile_disable, & + perf_timer_in=profile_timer, & + timer_depth_limit_in=profile_depth_limit, & + timing_detail_limit_in=profile_detail_limit, & + timing_barrier_in=profile_barrier, & + perf_outpe_num_in=profile_outpe_num, & + perf_outpe_stride_in=profile_outpe_stride, & + perf_single_file_in=profile_single_file, & + perf_global_stats_in=profile_global_stats, & + perf_papi_enable_in=profile_papi_enable, & + perf_ovhd_measurement_in=profile_ovhd_measurement, & + perf_add_detail_in=profile_add_detail ) + + ! Set PAPI defaults, then override with user-specified input + if (perf_papi_enable) then + call papi_defaultopts(papi_ctr1_out=papi_ctr1_id, & + papi_ctr2_out=papi_ctr2_id, & + papi_ctr3_out=papi_ctr3_id, & + papi_ctr4_out=papi_ctr4_id ) + + if ( MasterTask2 ) then + papi_ctr1_str = "PAPI_NO_CTR" + papi_ctr2_str = "PAPI_NO_CTR" + papi_ctr3_str = "PAPI_NO_CTR" + papi_ctr4_str = "PAPI_NO_CTR" + + + ! Read in the papi_inparm namelist from NLFilename if it exists + + write(p_logunit,*) '(t_initf) Read in papi_inparm namelist from: '//trim(NLFilename) + unitn = shr_file_getUnit() + + ierr = 1 + open( unitn, file=trim(NLFilename), status='old', iostat=ierr ) + if (ierr .eq. 0) then + ! Look for papi_inparm group name in the input file. + ! If found, leave the file positioned at that namelist group. + call find_group_name(unitn, 'papi_inparm', status=ierr) + + if (ierr == 0) then ! found papi_inparm + read(unitn, nml=papi_inparm, iostat=ierr) + if (ierr /= 0) then + call shr_sys_abort( subname//':: namelist read returns an'// & + ' error condition for papi_inparm' ) + end if + end if + + close(unitn) + + endif + call shr_file_freeUnit( unitn ) + + ! if enabled and nothing set, use "defaults" + if ((papi_ctr1_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr2_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr3_str(1:11) .eq. "PAPI_NO_CTR") .and. & + (papi_ctr4_str(1:11) .eq. "PAPI_NO_CTR")) then +!pw papi_ctr1_str = "PAPI_TOT_CYC" +!pw papi_ctr2_str = "PAPI_TOT_INS" +!pw papi_ctr3_str = "PAPI_FP_OPS" +!pw papi_ctr4_str = "PAPI_FP_INS" + papi_ctr1_str = "PAPI_FP_OPS" + endif + + if (papi_ctr1_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr1_str), papi_ctr1_id) + endif + if (papi_ctr2_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr2_str), papi_ctr2_id) + endif + if (papi_ctr3_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr3_str), papi_ctr3_id) + endif + if (papi_ctr4_str(1:11) /= "PAPI_NO_CTR") then + ierr = gptlevent_name_to_code(trim(papi_ctr4_str), papi_ctr4_id) + endif + + endif + ! This logic assumes that there will be only one MasterTask + ! per communicator, and that this MasterTask is process 0. + if ( present(MasterTask) .and. present(mpicom) )then + call shr_mpi_bcast( papi_ctr1_id, MPICom ) + call shr_mpi_bcast( papi_ctr2_id, MPICom ) + call shr_mpi_bcast( papi_ctr3_id, MPICom ) + call shr_mpi_bcast( papi_ctr4_id, MPICom ) + end if + + call papi_setopts (papi_ctr1_in=papi_ctr1_id, & + papi_ctr2_in=papi_ctr2_id, & + papi_ctr3_in=papi_ctr3_id, & + papi_ctr4_in=papi_ctr4_id ) + endif +!$OMP END MASTER +!$OMP BARRIER + + if (timing_disable) return + +!$OMP MASTER + ! + ! Set options and initialize timing library. + ! + ! Set timer + if (gptlsetutr (perf_timer) < 0) call shr_sys_abort (subname//':: gptlsetutr') + ! + ! For logical settings, 2nd arg 0 + ! to gptlsetoption means disable, non-zero means enable + ! + ! Turn off CPU timing (expensive) + ! + if (gptlsetoption (gptlcpu, 0) < 0) call shr_sys_abort (subname//':: gptlsetoption') + ! + ! + ! +!pw if(present(MaxThreads)) then +!pw if (gptlsetoption (gptlmaxthreads, MaxThreads) < 0) call shr_sys_abort (subname//':: gptlsetoption') +!pw endif + ! + ! Set max timer depth + ! + if (gptlsetoption (gptldepthlimit, timer_depth_limit) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + ! + ! Set profile ovhd measurement (default is false) + ! + if (perf_ovhd_measurement) then + if (gptlsetoption (gptlprofile_ovhd, 1) < 0) & + call shr_sys_abort (subname//':: gptlsetoption') + endif + ! + ! Next 2 calls only work if PAPI is enabled. These examples enable counting + ! of total cycles and floating point ops, respectively + ! + if (perf_papi_enable) then + if (papi_ctr1 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr1, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr2 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr2, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr3 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr3, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + if (papi_ctr4 /= PAPI_NULL) then + if (gptlsetoption (papi_ctr4, 1) < 0) call shr_sys_abort (subname//':: gptlsetoption') + endif + endif + ! + ! Initialize the timing lib. This call must occur after all gptlsetoption + ! calls and before all other timing lib calls. + ! + if (gptlinitialize () < 0) call shr_sys_abort (subname//':: gptlinitialize') + timing_initialized = .true. +!$OMP END MASTER +!$OMP BARRIER + + return + end subroutine t_initf +! +!======================================================================== +! + subroutine t_finalizef() +!----------------------------------------------------------------------- +! Purpose: shut down timing library +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Local workspace----------------------------- +! + integer ierr ! GPTL error return +! +!----------------------------------------------------------------------- +! + if (.not. timing_initialized) return + +!$OMP MASTER + ierr = GPTLfinalize() + timing_initialized = .false. +!$OMP END MASTER +!$OMP BARRIER + + return + end subroutine t_finalizef + +!=============================================================================== + +end module perf_mod diff --git a/share/timing/perf_utils.F90 b/share/timing/perf_utils.F90 new file mode 100644 index 000000000000..34a77c1f39cf --- /dev/null +++ b/share/timing/perf_utils.F90 @@ -0,0 +1,535 @@ +module perf_utils + +!----------------------------------------------------------------------- +! +! Purpose: This module supplies the csm_share and CAM utilities +! needed by perf_mod.F90 (when the csm_share and CAM utilities +! are not available). +! +! Author: P. Worley, October 2007 +! +! $Id$ +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!- module boilerplate -------------------------------------------------- +!----------------------------------------------------------------------- + implicit none + private ! Make the default access private +#include + save + +!----------------------------------------------------------------------- +! Public interfaces ---------------------------------------------------- +!----------------------------------------------------------------------- + public perfutils_setunit + public shr_sys_abort + public shr_mpi_barrier + public shr_file_getUnit + public shr_file_freeUnit + public find_group_name + public to_lower + public shr_mpi_bcast + + interface shr_mpi_bcast ; module procedure & + shr_mpi_bcastl0, & + shr_mpi_bcasti0 + end interface + +!----------------------------------------------------------------------- +! Private interfaces --------------------------------------------------- +!----------------------------------------------------------------------- + private shr_sys_flush + private shr_mpi_chkerr + private shr_mpi_abort + +!----------------------------------------------------------------------- +!- include statements -------------------------------------------------- +!----------------------------------------------------------------------- +#include "gptl.inc" + +!----------------------------------------------------------------------- +! Public data --------------------------------------------------------- +!----------------------------------------------------------------------- + + !---------------------------------------------------------------------------- + ! precision/kind constants (from csm_share/shr/shr_kind_mod.F90) + !---------------------------------------------------------------------------- + integer,parameter,public :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real + integer,parameter,public :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer + integer,parameter,public :: SHR_KIND_IN = kind(1) ! native integer + integer,parameter,public :: SHR_KIND_CS = 80 ! short char + integer,parameter,public :: SHR_KIND_CM = 160 ! mid-sized char + integer,parameter,public :: SHR_KIND_CL = 256 ! long char + integer,parameter,public :: SHR_KIND_CX = 512 ! extra-long char + +!----------------------------------------------------------------------- +! Private data --------------------------------------------------------- +!----------------------------------------------------------------------- + + integer, parameter :: def_pu_logunit = 6 ! default + integer, private :: pu_logunit = def_pu_logunit + ! unit number for log output + +!======================================================================= +contains +!======================================================================= + +! +!======================================================================== +! + subroutine perfutils_setunit(LogUnit) +!----------------------------------------------------------------------- +! Purpose: Set log unit number. +! Author: P. Worley +!----------------------------------------------------------------------- +!---------------------------Input arguments----------------------------- +! + integer(SHR_KIND_IN), intent(IN) :: LogUnit ! Unit number for log output +!----------------------------------------------------------------------- + pu_logunit = LogUnit +! + return +! + end subroutine perfutils_setunit + +!============== Routines from csm_share/shr/shr_sys_mod.F90 ============ +!======================================================================= + +SUBROUTINE shr_sys_abort(string) + + IMPLICIT none + + character(*) ,optional :: string ! error message string + + !----- local ----- + integer(SHR_KIND_IN) :: ierr + logical :: flag + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_abort) ' + character(*),parameter :: F00 = "('(shr_sys_abort) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: consistent stopping mechanism +! (dumbed down from original shr_sys_mod.F90 version for use in perf_mod) +!------------------------------------------------------------------------------- + + call shr_sys_flush(pu_logunit) + + if ( present(string) ) then + if (len_trim(string) > 0) then + write(pu_logunit,*) trim(subName),' ERROR: ',trim(string) + else + write(pu_logunit,*) trim(subName),' ERROR ' + endif + else + write(pu_logunit,*) trim(subName),' ERROR ' + endif + + write(pu_logunit,F00) 'WARNING: calling mpi_abort() and stopping' + call shr_sys_flush(pu_logunit) + call mpi_abort(MPI_COMM_WORLD,0,ierr) + call shr_sys_flush(pu_logunit) +#ifndef CPRNAG + call abort() +#endif + + stop + +END SUBROUTINE shr_sys_abort + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_sys_flush(unit) + + IMPLICIT none + + !----- arguments ----- + integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit + + !----- formats ----- + character(*),parameter :: subName = '(shr_sys_flush) ' + character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" + +!------------------------------------------------------------------------------- +! PURPOSE: an architecture independant system call +!------------------------------------------------------------------------------- + +#if (defined IRIX64 || defined CRAY || defined OSF1 || defined SUNOS || defined LINUX || defined NEC_SX || defined UNICOSMP) +#ifdef CPRNAG + flush(unit) +#else + call flush(unit) +#endif +#endif +#if (defined AIX) + call flush_(unit) +#endif + +END SUBROUTINE shr_sys_flush + +!=============================================================================== + +!================== Routines from csm_share/shr/shr_mpi_mod.F90 =============== +!=============================================================================== + +SUBROUTINE shr_mpi_chkerr(rcode,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code + character(*), intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_chkerr) ' + character(MPI_MAX_ERROR_STRING) :: lstring + integer(SHR_KIND_IN) :: len + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: layer on MPI error checking +!------------------------------------------------------------------------------- + + if (rcode /= MPI_SUCCESS) then + call MPI_ERROR_STRING(rcode,lstring,len,ierr) + write(pu_logunit,*) trim(subName),":",lstring(1:len) + call shr_mpi_abort(string,rcode) + endif + +END SUBROUTINE shr_mpi_chkerr + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_abort(string,rcode) + + IMPLICIT none + + !----- arguments --- + character(*),optional,intent(in) :: string ! message + integer,optional,intent(in) :: rcode ! optional code + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_abort) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI abort +!------------------------------------------------------------------------------- + + if ( present(string) .and. present(rcode) ) then + write(pu_logunit,*) trim(subName),":",trim(string),rcode + endif + call MPI_ABORT(MPI_COMM_WORLD,rcode,ierr) + +END SUBROUTINE shr_mpi_abort + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_barrier(comm,string) + + IMPLICIT none + + !----- arguments --- + integer,intent(in) :: comm + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_barrier) ' + integer(SHR_KIND_IN) :: ierr + +!------------------------------------------------------------------------------- +! PURPOSE: MPI barrier +!------------------------------------------------------------------------------- + + call MPI_BARRIER(comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_barrier + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcasti0(vec,comm,string) + + IMPLICIT none + + !----- arguments --- + integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcasti0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast an integer +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_BCAST(vec,lsize,MPI_INTEGER,0,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcasti0 + +!=============================================================================== +!=============================================================================== + +SUBROUTINE shr_mpi_bcastl0(vec,comm,string) + + IMPLICIT none + + !----- arguments --- + logical, intent(inout):: vec ! vector of 1 + integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator + character(*),optional,intent(in) :: string ! message + + !----- local --- + character(*),parameter :: subName = '(shr_mpi_bcastl0) ' + integer(SHR_KIND_IN) :: ierr + integer(SHR_KIND_IN) :: lsize + +!------------------------------------------------------------------------------- +! PURPOSE: Broadcast a logical +!------------------------------------------------------------------------------- + + lsize = 1 + + call MPI_BCAST(vec,lsize,MPI_LOGICAL,0,comm,ierr) + if (present(string)) then + call shr_mpi_chkerr(ierr,subName//trim(string)) + else + call shr_mpi_chkerr(ierr,subName) + endif + +END SUBROUTINE shr_mpi_bcastl0 + +!=============================================================================== + +!================== Routines from csm_share/shr/shr_file_mod.F90 =============== +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_getUnit -- Get a free FORTRAN unit number +! +! !DESCRIPTION: Get the next free FORTRAN unit number. +! +! !REVISION HISTORY: +! 2005-Dec-14 - E. Kluzek - creation +! 2007-Oct-21 - P. Worley - dumbed down for use in perf_mod +! +! !INTERFACE: ------------------------------------------------------------------ + +INTEGER FUNCTION shr_file_getUnit () + + implicit none + +!EOP + + !----- local parameters ----- + integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10 ! Min unit number to give + integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99 ! Max unit number to give + + !----- local variables ----- + integer(SHR_KIND_IN) :: n ! loop index + logical :: opened ! If unit opened or not + + !----- formats ----- + character(*),parameter :: subName = '(shr_file_getUnit) ' + character(*),parameter :: F00 = "('(shr_file_getUnit) ',A,I4,A)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + ! --- Choose first available unit other than 0, 5, or 6 ------ + do n=shr_file_minUnit, shr_file_maxUnit + inquire( n, opened=opened ) + if (n == 5 .or. n == 6 .or. opened) then + cycle + end if + shr_file_getUnit = n + return + end do + + call shr_sys_abort( subName//': Error: no available units found' ) + +END FUNCTION shr_file_getUnit +!=============================================================================== + +!=============================================================================== +!BOP =========================================================================== +! +! !IROUTINE: shr_file_freeUnit -- Free up a FORTRAN unit number +! +! !DESCRIPTION: Free up the given unit number +! +! !REVISION HISTORY: +! 2005-Dec-14 - E. Kluzek - creation +! 2007-Oct-21 - P. Worley - dumbed down for use in perf_mod +! +! !INTERFACE: ------------------------------------------------------------------ + +SUBROUTINE shr_file_freeUnit ( unit) + + implicit none + +! !INPUT/OUTPUT PARAMETERS: + + integer(SHR_KIND_IN),intent(in) :: unit ! unit number to be freed + +!EOP + + !----- local parameters ----- + integer(SHR_KIND_IN),parameter :: shr_file_minUnit = 10 ! Min unit number to give + integer(SHR_KIND_IN),parameter :: shr_file_maxUnit = 99 ! Max unit number to give + + !----- formats ----- + character(*), parameter :: subName = '(shr_file_freeUnit) ' + character(*), parameter :: F00 = "('(shr_file_freeUnit) ',A,I4,A)" + +!------------------------------------------------------------------------------- +! Notes: +!------------------------------------------------------------------------------- + + if (unit < 0 .or. unit > shr_file_maxUnit) then +!pw if (s_loglev > 0) write(pu_logunit,F00) 'invalid unit number request:', unit + else if (unit == 0 .or. unit == 5 .or. unit == 6) then + call shr_sys_abort( subName//': Error: units 0, 5, and 6 must not be freed' ) + end if + + return + +END SUBROUTINE shr_file_freeUnit +!=============================================================================== + +!============= Routines from atm/cam/src/utils/namelist_utils.F90 ============== +!=============================================================================== + +subroutine find_group_name(unit, group, status) + +!--------------------------------------------------------------------------------------- +! Purpose: +! Search a file that contains namelist input for the specified namelist group name. +! Leave the file positioned so that the current record is the first record of the +! input for the specified group. +! +! Method: +! Read the file line by line. Each line is searched for an '&' which may only +! be preceded by blanks, immediately followed by the group name which is case +! insensitive. If found then backspace the file so the current record is the +! one containing the group name and return success. Otherwise return -1. +! +! Author: B. Eaton, August 2007 +!--------------------------------------------------------------------------------------- + + integer, intent(in) :: unit ! fortran unit attached to file + character(len=*), intent(in) :: group ! namelist group name + integer, intent(out) :: status ! 0 for success, -1 if group name not found + + ! Local variables + + integer :: len_grp + integer :: ios ! io status + character(len=80) :: inrec ! first 80 characters of input record + character(len=80) :: inrec2 ! left adjusted input record + character(len=len(group)) :: lc_group + + !--------------------------------------------------------------------------- + + len_grp = len_trim(group) + lc_group = to_lower(group) + + ios = 0 + do while (ios <= 0) + + read(unit, '(a)', iostat=ios, end=102) inrec + + if (ios <= 0) then ! ios < 0 indicates an end of record condition + + ! look for group name in this record + + ! remove leading blanks + inrec2 = to_lower(adjustl(inrec)) + + ! check for leading '&' + if (inrec2(1:1) == '&') then + + ! check for case insensitive group name + if (trim(lc_group) == inrec2(2:len_grp+1)) then + + ! found group name. backspace to leave file position at this record + backspace(unit) + status = 0 + return + + end if + end if + end if + + end do + + 102 continue ! end of file processing + status = -1 + +end subroutine find_group_name +!=============================================================================== + +!================ Routines from atm/cam/src/utils/string_utils.F90 ============= +!=============================================================================== + +function to_lower(str) + +!----------------------------------------------------------------------- +! Purpose: +! Convert character string to lower case. +! +! Method: +! Use achar and iachar intrinsics to ensure use of ascii collating sequence. +! +! Author: B. Eaton, July 2001 +! +! $Id$ +!----------------------------------------------------------------------- + implicit none + + character(len=*), intent(in) :: str ! String to convert to lower case + character(len=len(str)) :: to_lower + +! Local variables + + integer :: i ! Index + integer :: aseq ! ascii collating sequence + integer :: upper_to_lower ! integer to convert case + character(len=1) :: ctmp ! Character temporary +!----------------------------------------------------------------------- + upper_to_lower = iachar("a") - iachar("A") + + do i = 1, len(str) + ctmp = str(i:i) + aseq = iachar(ctmp) + if ( aseq >= iachar("A") .and. aseq <= iachar("Z") ) & + ctmp = achar(aseq + upper_to_lower) + to_lower(i:i) = ctmp + end do + +end function to_lower +!=============================================================================== + +end module perf_utils diff --git a/share/timing/private.h b/share/timing/private.h new file mode 100644 index 000000000000..42a71de8ccef --- /dev/null +++ b/share/timing/private.h @@ -0,0 +1,160 @@ +/* +** $Id: private.h,v 1.74 2011-03-28 20:55:19 rosinski Exp $ +** +** Author: Jim Rosinski +** +** Contains definitions private to GPTL and inaccessible to invoking user environment +*/ + +#include +#include + +#ifndef NO_COMM_F2C +#define HAVE_COMM_F2C +#endif + +#ifndef MIN +#define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) +#endif + +#ifndef MAX +#define MAX(X,Y) ((X) > (Y) ? (X) : (Y)) +#endif + +#define STRMATCH(X,Y) (strcmp((X),(Y)) == 0) + +#define STRNMATCH(X,Y,N) (strncmp((X),(Y),(N)) == 0) + +/* Output counts less than PRTHRESH will be printed as integers */ +#define PRTHRESH 1000000L + +/* Maximum allowed callstack depth */ +#define MAX_STACK 128 + +/* longest timer name allowed (probably safe to just change) */ +#define MAX_CHARS 127 + +/* +** max allowable number of PAPI counters, or derived events. For convenience, +** set to max (# derived events, # papi counters required) so "avail" lists +** all available options. +*/ +#define MAX_AUX 9 + +#ifndef __cplusplus +typedef enum {false = 0, true = 1} bool; /* mimic C++ */ +#endif + +typedef struct { + long last_utime; /* saved usr time from "start" */ + long last_stime; /* saved sys time from "start" */ + long accum_utime; /* accumulator for usr time */ + long accum_stime; /* accumulator for sys time */ +} Cpustats; + +typedef struct { + double last; /* timestamp from last call */ + double accum; /* accumulated time */ + float max; /* longest time for start/stop pair */ + float min; /* shortest time for start/stop pair */ +} Wallstats; + +typedef struct { + long long last[MAX_AUX]; /* array of saved counters from "start" */ + long long accum[MAX_AUX]; /* accumulator for counters */ +} Papistats; + +typedef struct { + int counter; /* PAPI or Derived counter */ + char *namestr; /* PAPI or Derived counter as string */ + char *str8; /* print string for output timers (8 chars) */ + char *str16; /* print string for output timers (16 chars) */ + char *longstr; /* long descriptive print string */ +} Entry; + +typedef struct { + Entry event; + int numidx; /* derived event: PAPI counter array index for numerator */ + int denomidx; /* derived event: PAPI counter array index for denominator */ +} Pr_event; + +typedef struct TIMER { + char name[MAX_CHARS+1]; /* timer name (user input) */ + bool onflg; /* timer currently on or off */ +#ifdef ENABLE_PMPI + double nbytes; /* number of bytes for MPI call */ +#endif +#ifdef HAVE_PAPI + Papistats aux; /* PAPI stats */ +#endif + Wallstats wall; /* wallclock stats */ + Cpustats cpu; /* cpu stats */ + unsigned long count; /* number of start/stop calls */ + unsigned long nrecurse; /* number of recursive start/stop calls */ + void *address; /* address of timer: used only by _instr routines */ + struct TIMER *next; /* next timer in linked list */ + struct TIMER **parent; /* array of parents */ + struct TIMER **children; /* array of children */ + int *parent_count; /* array of call counts, one for each parent */ + unsigned int recurselvl; /* recursion level */ + unsigned int nchildren; /* number of children */ + unsigned int nparent; /* number of parents */ + unsigned int norphan; /* number of times this timer was an orphan */ + int num_desc; /* number of descendants */ +} Timer; + +typedef struct { + Timer **entries; /* array of timers hashed to the same value */ + unsigned int nument; /* number of entries hashed to the same value */ +} Hashentry; + +/* Function prototypes */ + +extern int GPTLerror (const char *, ...); /* print error msg and return */ +extern void GPTLset_abort_on_error (bool val); /* set flag to abort on error */ +extern void *GPTLallocate (const int); /* malloc wrapper */ + +extern int GPTLstart_instr (void *); /* auto-instrumented start */ +extern int GPTLstop_instr (void *); /* auto-instrumented stop */ +extern int GPTLis_initialized (void); /* needed by MPI_Init wrapper */ + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef AUTO_INST +extern void __cyg_profile_func_enter (void *, void *); +extern void __cyg_profile_func_exit (void *, void *); +#endif + +#ifdef __cplusplus +}; +#endif + +/* +** These are needed for communication between gptl.c and gptl_papi.c +*/ + +#ifdef HAVE_PAPI +extern int GPTL_PAPIsetoption (const int, const int); +extern int GPTL_PAPIinitialize (const int, const bool, int *, Entry *); +extern int GPTL_PAPIstart (const int, Papistats *); +extern int GPTL_PAPIstop (const int, Papistats *); +extern void GPTL_PAPIprstr (FILE *); +extern void GPTL_PAPIpr (FILE *, const Papistats *, const int, const int, const double); +extern void GPTL_PAPIadd (Papistats *, const Papistats *); +extern void GPTL_PAPIfinalize (int); +extern void GPTL_PAPIquery (const Papistats *, long long *, int); +extern int GPTL_PAPIget_eventvalue (const char *, const Papistats *, double *); +extern bool GPTL_PAPIis_multiplexed (void); +extern void GPTL_PAPIprintenabled (FILE *); +extern void read_counters100 (void); +extern int GPTLget_npapievents (void); +extern int GPTLcreate_and_start_events (const int); +#endif + +#ifdef ENABLE_PMPI +extern Timer *GPTLgetentry (const char *); +extern int GPTLpmpi_setoption (const int, const int); +extern int GPTLpr_has_been_called (void); /* needed by MPI_Finalize wrapper*/ +#endif