diff --git a/.circleci/config.yml b/.circleci/config.yml index de7b95929ac..b0bbe2fdcc1 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -82,7 +82,7 @@ workflows: baselibs_version: *baselibs_version repo: MAPL mepodevelop: false - extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_SHARED_MAPL=OFF" + extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_WITH_FARGPARSE=OFF -DUSE_EXTDATA2G=OFF -DBUILD_SHARED_MAPL=OFF" run_unit_tests: true ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml index 26351cbd5f0..fd525b2a4b3 100644 --- a/.github/workflows/push-to-develop.yml +++ b/.github/workflows/push-to-develop.yml @@ -11,11 +11,11 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout repo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 0 - name: Run the action - uses: devops-infra/action-pull-request@v0.5.3 + uses: devops-infra/action-pull-request@v0.5.5 with: github_token: ${{ secrets.GITHUB_TOKEN }} source_branch: develop diff --git a/.github/workflows/push-to-main.yml b/.github/workflows/push-to-main.yml index aded8b19cc3..07114a4aaad 100644 --- a/.github/workflows/push-to-main.yml +++ b/.github/workflows/push-to-main.yml @@ -11,11 +11,11 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout repo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 0 - name: Run the action - uses: devops-infra/action-pull-request@v0.5.3 + uses: devops-infra/action-pull-request@v0.5.5 with: github_token: ${{ secrets.GITHUB_TOKEN }} source_branch: main diff --git a/.github/workflows/release-tarball.yml b/.github/workflows/release-tarball.yml index 732280a0260..41f2838932a 100644 --- a/.github/workflows/release-tarball.yml +++ b/.github/workflows/release-tarball.yml @@ -10,12 +10,12 @@ jobs: steps: - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: path: ${{ github.event.repository.name }}-${{ github.event.release.tag_name }} - name: Checkout mepo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: repository: GEOS-ESM/mepo path: mepo diff --git a/.github/workflows/validate_yaml_files.yml b/.github/workflows/validate_yaml_files.yml index 1b475fc4e4a..86df2bb00b7 100644 --- a/.github/workflows/validate_yaml_files.yml +++ b/.github/workflows/validate_yaml_files.yml @@ -15,7 +15,7 @@ jobs: validate-YAML: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3.2.0 + - uses: actions/checkout@v3.3.0 - id: yaml-lint name: yaml-lint uses: ibiqlik/action-yamllint@v3 diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 22b5f5c2c19..ac6ebd4acf3 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -34,7 +34,7 @@ jobs: with: access_token: ${{ github.token }} - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 1 - name: Set all directories as git safe @@ -90,7 +90,7 @@ jobs: with: access_token: ${{ github.token }} - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 1 - name: Set all directories as git safe diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index a018d016795..cb7aa8bd839 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -171,7 +171,7 @@ subroutine process_command_line(this,rc) if (.not.allocated(this%tripolar_file_out)) then this%tripolar_file_out = "empty" end if - this%regridMethod = get_regrid_method(regridMth) + this%regridMethod = regrid_method_string_to_int(regridMth) _ASSERT(this%regridMethod/=UNSPECIFIED_REGRID_METHOD,"improper regrid method chosen") this%filenames = split_string(cfilenames,',') diff --git a/CHANGELOG.md b/CHANGELOG.md index 1db389117f9..82e2c24b6d3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,53 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.35.0] - 2023-03-01 + +### Added + +- Added subroutines to read char type in Netcdf +- Added a subroutine add_variable to Netcdf4_Fileformatter +- Add a function to get the area of a spherical polygon to the spherical geometry module +- Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes +- Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This + provides a convenient local solar hour angle diagnostic which will be used to detect local + solar noon via the `EXAMPLE OF USE` in the subroutine header. See `DESCRIPTION` in code + for more details. Provides the TRUE local solar hour angle (i.e., with equation of time + included), but can also provide the MEAN value (without EOT) via `FORCE_MLSHA=.TRUE.` + optional argument. +- Add `shavemantissa` f2py code. This is used by AeroApps. + - NOTE: If you do not have a need for this code, build with `-DUSE_F2PY=OFF`. Note that even if you try to build the f2py code, it might fail anyway due to issues with the Python stack on the machine. ESMA_cmake has code that "tests" if f2py works. If it doesn't, it should failover gracefully. + +### Changed + +- Changed set_grid method so users have a chance to specify the grid type +- Renamed `get_regrid_method` and `translate_regrid_method` to `regrid_method_string_to_int` and `regrid_method_int_to_string` + respectively in `RegridMethods.F90`. This was done so we could add `get_regrid_method` to the AbstractRegridder. The new names + more accurately reflect what the RegridMethods functions do. +- Changed call to `MAPL_SunOrbitCreate()` inside `MAPL_Generic.F90` to call to new function + `MAPL_SunOrbitCreateFromConfig()`, the latter which get the orbital parameters from the MAPL + state's Config. In this way no default orbital parameter values need appear in `MAPL_Generic.F90`. + Rather, these default values are encapsulated where they belong in `Sun_Mod` in `base/MAPL_sun_uc.F90` + and are now explicitly named and commented on at the head of the module. This is a structural + zero-diff change. +- Created `MAPL.profiler` logger and moved throughput, per-component, and global timers to use it +- Moved most of the MAPL_GetResource generic subroutine to a new module, MAPL_ResourceMod, in base. + The specific subroutines remain in MAPL_GenericMod to maintain the interface in one module, but + most of the functionality is in MAPL_ResourceMod now. +- Update "build like UFS" CI test +- Converted the History Gridded Component to use `_RC` and `_STAT` macros + +### Fixed + +- Changed the type of output counters to INT64 for large file. +- Tested optional arguments arrdes in MAPL_WriteVars +- Added the correct values to halo corner of LatLon grid +- Fixed range in halo of LatLonGridFactory +- Corrected issue with native output having metadata saying it was bilinearly regridded. Now sets these files to have + `regrid_method: identity` +- Fix bug in `mapl_acg.cmake` that caused unnecessary rebuilds +- Fixed error handling for refactored MAPL_GetResource + ## [2.34.3] - 2023-02-14 ### Added diff --git a/CMakeLists.txt b/CMakeLists.txt index 632ca280074..1749a95cf39 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,7 +4,7 @@ cmake_policy (SET CMP0054 NEW) project ( MAPL - VERSION 2.34.3 + VERSION 2.35.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the default build type to release diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index e6cfd498a7f..ac0ed525738 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -54,3 +54,23 @@ if (precision MATCHES "r8") target_compile_options (${lib} PRIVATE $<$:${flag}>) endforeach () endif () + +if (USE_F2PY) + if (precision STREQUAL "r4") + find_package(F2PY2) + if (F2PY2_FOUND) + esma_add_f2py2_module(ShaveMantissa_ + SOURCES ShaveMantissa_py.F90 ShaveMantissa.c + DESTINATION lib/Python/${this} + INCLUDEDIRS ${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_BINARY_DIR}/lib ${include_${this}} + ) + add_dependencies(ShaveMantissa_ ${this}) + + # Install the Python files + install ( + FILES shavemantissa.py + DESTINATION lib/Python/${this} + ) + endif () + endif () +endif () diff --git a/MAPL_cfio/ShaveMantissa_py.F90 b/MAPL_cfio/ShaveMantissa_py.F90 new file mode 100644 index 00000000000..b6dd6433fa1 --- /dev/null +++ b/MAPL_cfio/ShaveMantissa_py.F90 @@ -0,0 +1,26 @@ +subroutine Shave32 ( a_shaved, a, n, xbits, has_undef, undef, chunksize, rc ) + +! +! Simple cover for f2py. +! + use iso_fortran_env, only: REAL32 + implicit NONE + integer, intent(in) :: n ! array size + real(kind=REAL32), intent(in) :: a(n) ! array to be shaved, usually 2D + integer, intent(in) :: xbits ! number of mantissa bits to zero (out of 24) + integer, intent(in) :: has_undef ! set to 1 if undef is present, 0 otherwise + real(kind=REAL32), intent(in) :: undef ! undef value + integer, intent(in) :: chunksize ! find mid-range over chunksizes + + real(kind=REAL32), intent(out) :: a_shaved(n) ! shaved array + integer, intent(out) :: rc ! error code + +! --- + + integer, external :: ShaveMantissa32 + + rc = ShaveMantissa32(a_shaved,a,n,xbits,has_undef,undef,chunksize) + +end subroutine Shave32 + + diff --git a/MAPL_cfio/shavemantissa.py b/MAPL_cfio/shavemantissa.py new file mode 100644 index 00000000000..318d363c13b --- /dev/null +++ b/MAPL_cfio/shavemantissa.py @@ -0,0 +1,36 @@ +""" + SImple python interface to the ShaveMantissa function +""" + +MISSING = 1.0E15 + +from ShaveMantissa_ import shave32 + +def shave(a,xbits=12,has_undef=0,undef=MISSING,chunksize=-1): + """ + Shaves bits from mantissa of float point array for better netCDF4 compression + using gzip. + + a_shaved = shave(a,...) + + xbits --- number of bits to shave + has_undef --- set to 1 if undefs are present + undef --- undef value + chunksize --- for scaling of array to be shaved: find mid-range value + over chunksizes. If negative, set to len(a) + + Typically this function is used for a single vertical slice at time. + + + """ + + n = len(a) + if chunksize<0: chunksize = n + + a_shaved, rc = shave32(a,xbits,has_undef,undef,chunksize) + + if rc: + raise ValueError, 'shave: error on return from ShaveMantissa_.shave32: %d'%rc + + return a_shaved + diff --git a/Python/MAPL/constants.py b/Python/MAPL/constants.py index faeb9580a4e..431ebe07af1 100644 --- a/Python/MAPL/constants.py +++ b/Python/MAPL/constants.py @@ -6,12 +6,15 @@ MAPL_DEGREES_TO_RADIANS = MAPL_PI / 180.0 MAPL_RADIANS_TO_DEGREES = 180.0 / MAPL_PI +MAPL_UNDEF = 1.0e15 MAPL_PSDRY = 98305.0 # dry surface pressure [Pa] MAPL_SECONDS_PER_SIDEREAL_DAY = 86164.0 #s MAPL_GRAV = 9.80665 # m^2/s MAPL_RADIUS = 6371.0E3 # m MAPL_OMEGA = 2.0*MAPL_PI/MAPL_SECONDS_PER_SIDEREAL_DAY # 1/s +MAPL_RUNIV = 8314.47 # J/(Kmole K) +MAPL_H2OMW = 18.015 # kg/Kmole MAPL_EARTH_ECCENTRICITY = 8.1819190842622E-2 # -- MAPL_EARTH_SEMIMAJOR_AXIS = 6378137 # m MAPL_KM_PER_DEG = (1.0/(MAPL_RADIUS/1000.)) * MAPL_RADIANS_TO_DEGREES @@ -48,9 +51,7 @@ MAPL_STFBOL = 5.6734E-8 # W/(m^2 K^4) MAPL_AVOGAD = 6.023E26 # 1/kmol -MAPL_RUNIV = 8314.47 # J/(Kmole K) -MAPL_H2OMW = 18.015 # kg/Kmole MAPL_O3MW = 47.9982 # kg/Kmole MAPL_ALHL = 2.4665E6 # J/kg @15C MAPL_ALHF = 3.3370E5 # J/kg diff --git a/base/ApplicationSupport.F90 b/base/ApplicationSupport.F90 index 0eac83a95c4..9cb744b7e7e 100644 --- a/base/ApplicationSupport.F90 +++ b/base/ApplicationSupport.F90 @@ -23,7 +23,7 @@ subroutine MAPL_Initialize(unusable,comm,logging_config,rc) character(:), allocatable :: logging_configuration_file integer :: comm_world,status - + _UNUSED_DUMMY(unusable) if (present(logging_config)) then @@ -55,7 +55,7 @@ subroutine MAPL_Finalize(unusable,comm,rc) integer :: comm_world,status _UNUSED_DUMMY(unusable) - + if (present(comm)) then comm_world = comm else @@ -137,7 +137,7 @@ subroutine initialize_pflogger(unusable,comm,logging_config,rc) if (rank == 0) then lgr => logging%get_logger('MAPL') - call lgr%warning('No configure file specified for logging layer. Using defaults.') + call lgr%warning('No configure file specified for logging layer. Using defaults.') end if end if @@ -158,6 +158,7 @@ subroutine report_global_profiler(unusable,comm,rc) integer :: npes, my_rank, ierror character(1) :: empty(0) class (BaseProfiler), pointer :: t_p + type(Logger), pointer :: lgr _UNUSED_DUMMY(unusable) if (present(comm)) then @@ -185,13 +186,14 @@ subroutine report_global_profiler(unusable,comm,rc) call MPI_Comm_Rank(world_comm, my_rank, ierror) if (my_rank == 0) then - report_lines = reporter%generate_report(t_p) - write(*,'(a,1x,i0)')'Report on process: ', my_rank - do i = 1, size(report_lines) - write(*,'(a)') report_lines(i) - end do - end if - call MPI_Barrier(world_comm, ierror) + report_lines = reporter%generate_report(t_p) + lgr => logging%get_logger('MAPL.profiler') + call lgr%info('Report on process: %i0', my_rank) + do i = 1, size(report_lines) + call lgr%info('%a', report_lines(i)) + end do + end if + call MPI_Barrier(world_comm, ierror) end subroutine report_global_profiler diff --git a/base/Base.F90 b/base/Base.F90 index 012aedc8b79..5413bcafbba 100644 --- a/base/Base.F90 +++ b/base/Base.F90 @@ -52,6 +52,7 @@ module MAPLBase_Mod use MAPL_FileMetadataUtilsMod use MAPL_VerticalDataMod use MAPL_FieldUtilities + use MAPL_SphericalGeometry logical, save, private :: mapl_is_initialized = .false. end module MAPLBase_Mod diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 091582d1e1a..4f281e674fa 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -53,6 +53,7 @@ set (srcs TimeStringConversion.F90 MAPL_ISO8601_DateTime_ESMF.F90 FieldUtilities.F90 + MAPL_Resource.F90 # Orphaned program: should not be in this library. # tstqsat.F90 ) @@ -60,7 +61,8 @@ set (srcs esma_add_library( ${this} SRCS ${srcs} - DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger GFTL_SHARED::gftl-shared + DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger + GFTL_SHARED::gftl-shared-v2 GFTL_SHARED::gftl-shared-v1 GFTL::gftl-v2 GFTL::gftl-v1 esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran TYPE ${MAPL_LIBRARY_TYPE}) diff --git a/base/MAPL_AbstractRegridder.F90 b/base/MAPL_AbstractRegridder.F90 index 30ffeb83017..52aa6364a38 100644 --- a/base/MAPL_AbstractRegridder.F90 +++ b/base/MAPL_AbstractRegridder.F90 @@ -11,7 +11,7 @@ module MAPL_AbstractRegridderMod use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private - + public :: AbstractRegridder type, abstract :: AbstractRegridder @@ -29,7 +29,7 @@ module MAPL_AbstractRegridderMod procedure :: get_spec procedure :: set_spec procedure :: isTranspose - + procedure :: regrid_scalar_2d_real32 procedure :: regrid_scalar_2d_real64 procedure :: regrid_scalar_3d_real32 @@ -44,7 +44,7 @@ module MAPL_AbstractRegridderMod ! interfaces. procedure :: regrid_esmf_fields_scalar procedure :: regrid_esmf_fields_vector - + ! Generic overload generic :: regrid => regrid_esmf_fields_scalar generic :: regrid => regrid_esmf_fields_vector @@ -90,6 +90,7 @@ module MAPL_AbstractRegridderMod procedure :: get_undef_value procedure :: clear_undef_value procedure :: has_undef_value + procedure :: get_regrid_method end type AbstractRegridder @@ -105,7 +106,7 @@ subroutine initialize_subclass(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc end subroutine initialize_subclass - + end interface character(len=*), parameter :: MOD_NAME = 'MAPL_AbstractRegridder::' @@ -272,7 +273,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in type (ESMF_Field), intent(in) :: f_out integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'regrid_esmf_fields' integer :: rank_in type (ESMF_TypeKind_Flag) :: typekind_in @@ -298,7 +299,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL32), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -311,7 +312,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL64), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -356,13 +357,13 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported type kind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine regrid_esmf_fields_scalar @@ -377,7 +378,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in(NUM_DIM) type (ESMF_Field), intent(in) :: f_out(NUM_DIM) integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'regrid_esmf_fields' integer :: rank_in(NUM_DIM) type (ESMF_TypeKind_Flag) :: typekind_in(NUM_DIM) @@ -413,7 +414,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:), v_in(:,:) real(REAL32), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -431,7 +432,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:), v_in(:,:) real(REAL64), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -455,7 +456,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL32), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -473,7 +474,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL64), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -489,19 +490,19 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported type-kind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine regrid_esmf_fields_vector ! Begin - transpose interfaces - + subroutine transpose_regrid_scalar_2d_real32(this, q_in, q_out, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: q_in(:,:) @@ -531,7 +532,7 @@ subroutine transpose_regrid_scalar_2d_real64(this, q_in, q_out, rc) _RETURN(_FAILURE) end subroutine transpose_regrid_scalar_2d_real64 - + subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: q_in(:,:,:) @@ -563,7 +564,7 @@ subroutine transpose_regrid_scalar_3d_real64(this, q_in, q_out, rc) end subroutine transpose_regrid_scalar_3d_real64 - + subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: u_in(:,:) @@ -585,7 +586,7 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_2d_real32 @@ -610,7 +611,7 @@ subroutine transpose_regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_2d_real64 @@ -635,7 +636,7 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_3d_real32 @@ -658,7 +659,7 @@ subroutine transpose_regrid_vector_3d_real64(this, u_in, v_in, u_out, v_out, rc) u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_3d_real64 @@ -672,7 +673,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in type (ESMF_Field), intent(in) :: f_out integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_esmf_fields' integer :: rank_in type (ESMF_TypeKind_Flag) :: typekind_in @@ -698,7 +699,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL32), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -711,7 +712,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL64), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -756,13 +757,13 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported typekind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine transpose_regrid_esmf_fields_scalar @@ -777,7 +778,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in(NUM_DIM) type (ESMF_Field), intent(in) :: f_out(NUM_DIM) integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_esmf_fields' integer :: rank_in(NUM_DIM) type (ESMF_TypeKind_Flag) :: typekind_in(NUM_DIM) @@ -813,7 +814,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:), v_in(:,:) real(REAL32), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -831,7 +832,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:), v_in(:,:) real(REAL64), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -855,7 +856,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL32), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -873,7 +874,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL64), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -889,13 +890,13 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported typekind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine transpose_regrid_esmf_fields_vector @@ -940,7 +941,7 @@ function get_spec(this) result(spec) class (AbstractRegridder), intent(in) :: this spec = this%spec end function get_spec - + subroutine set_spec(this, spec) class(AbstractRegridder), intent(inout) :: this type(RegridderSpec), intent(in) :: spec @@ -974,7 +975,7 @@ subroutine initialize_base(this, spec, unusable, rc) _RETURN(_SUCCESS) end subroutine initialize_base - + function clone(this) class (AbstractRegridder), allocatable :: clone class (AbstractRegridder), intent(in) :: this @@ -1000,4 +1001,9 @@ logical function supports(spec, unusable, rc) end function supports + integer function get_regrid_method(this) result(method) + class (AbstractRegridder), intent(in) :: this + method = this%spec%regrid_method + end function get_regrid_method + end module MAPL_AbstractRegridderMod diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 51d86ae8c74..aaa63fbb973 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -208,6 +208,7 @@ module MAPL_CommsMod interface MAPL_CommsSendRecv module procedure MAPL_CommsSendRecv_I4_0 + module procedure MAPL_CommsSendRecv_R4_0 module procedure MAPL_CommsSendRecv_R4_1 module procedure MAPL_CommsSendRecv_R4_2 module procedure MAPL_CommsSendRecv_R8_1 @@ -1479,6 +1480,11 @@ end subroutine MAPL_BcastShared_2DR4 #define VARTYPE_ 1 #include "sendrecv.H" +!--------------------------- +#define RANK_ 0 +#define VARTYPE_ 3 +#include "sendrecv.H" + !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 diff --git a/base/MAPL_IdentityRegridder.F90 b/base/MAPL_IdentityRegridder.F90 index c3514f4b59f..7b70900892d 100644 --- a/base/MAPL_IdentityRegridder.F90 +++ b/base/MAPL_IdentityRegridder.F90 @@ -8,7 +8,7 @@ module MAPL_IdentityRegridderMod use mapl_ErrorHandlingMod use mapl_RegridMethods use ESMF - + use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -38,15 +38,23 @@ module MAPL_IdentityRegridderMod character(len=*), parameter :: MOD_NAME = 'MAPL_IdentityRegridder::' type (IdentityRegridder), save, target :: singleton - + contains function identity_regridder() result(regridder) use ESMF type (IdentityRegridder), pointer :: regridder + type (RegridderSpec) :: spec regridder => singleton + + ! Due to how MAPL is set up, the default regrid_method is + ! bilinear. But if an identity regridder is requested, we + ! want to reflect that in the metadata by updating the spec. + spec = regridder%get_spec() + spec%regrid_method = REGRID_METHOD_IDENTITY + call regridder%set_spec(spec) end function identity_regridder @@ -63,7 +71,7 @@ subroutine regrid_scalar_2d_real32(this, q_in, q_out, rc) q_out = q_in _RETURN(_SUCCESS) - + end subroutine regrid_scalar_2d_real32 @@ -85,7 +93,7 @@ subroutine regrid_scalar_3d_real32(this, q_in, q_out, rc) q_out = q_in _RETURN(_SUCCESS) - + end subroutine regrid_scalar_3d_real32 subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) @@ -169,5 +177,5 @@ subroutine initialize_subclass(this, unusable, rc) _UNUSED_DUMMY(rc) end subroutine initialize_subclass - + end module MAPL_IdentityRegridderMod diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index f4df37d7cad..8cbba70dccc 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -1617,6 +1617,8 @@ subroutine halo(this, array, unusable, halo_width, rc) integer :: pet_south integer :: pet_east integer :: pet_west + integer :: pet_N_E, pet_N_W, pet_S_E, pet_S_W + integer :: last_lon, last_lat _UNUSED_DUMMY(unusable) ! not yet implmented, default is 1 @@ -1627,6 +1629,9 @@ subroutine halo(this, array, unusable, halo_width, rc) _VERIFY(status) end if + last_lon = size(array,1) + last_lat = size(array,2) + associate (nx => this%nx, ny => this% ny, px => this%px, py => this%py) ! Nearest neighbors processor' ids pet_north = get_pet(px, py+1, nx, ny) @@ -1644,6 +1649,51 @@ subroutine halo(this, array, unusable, halo_width, rc) call fill_west(array, rc=status) _VERIFY(status) + pet_N_E = get_pet(px+1, py+1, nx, ny) + pet_N_W = get_pet(px-1, py+1, nx, ny) + pet_S_E = get_pet(px+1, py-1, nx, ny) + pet_S_W = get_pet(px-1, py-1, nx, ny) + + !fill north east + call MAPL_CommsSendRecv(this%layout, & + array(2, 2 ), 1, pet_S_W, & + array(last_lon,last_lat ), 1, pet_N_E, & + rc=status) + _VERIFY(status) + + !fill north west + call MAPL_CommsSendRecv(this%layout, & + array(last_lon-1, 2), 1, pet_S_E, & + array(1, last_lat), 1, pet_N_W, & + rc=status) + _VERIFY(status) + + ! north pol corner + if(this%py== this%ny-1) then + array(last_lon,last_lat) = array(last_lon-1,last_lat-1) + array(1,last_lat) = array(2,last_lat-1) + endif + + !fill south east + call MAPL_CommsSendRecv(this%layout, & + array(2, last_lat-1), 1, pet_N_W, & + array(last_lon,1), 1, pet_S_E, & + rc=status) + _VERIFY(status) + + !fill south west + call MAPL_CommsSendRecv(this%layout, & + array(last_lon-1,last_lat-1), 1, pet_N_E, & + array(1,1 ), 1, pet_S_W, & + rc=status) + _VERIFY(status) + + ! south pole corner + if(this%py==0) then + array(last_lon,1 ) = array(last_lon-1,2 ) + array(1,1 ) = array(2,2 ) + endif + end associate _RETURN(ESMF_SUCCESS) @@ -1718,8 +1768,8 @@ subroutine fill_east(array, rc) integer :: len, last - last = size(array,2)-1 - len = size(array,1) + last = size(array,1)-1 + len = size(array,2) call MAPL_CommsSendRecv(this%layout, & array(2 , : ), len, pet_west, & @@ -1744,8 +1794,8 @@ subroutine fill_west(array, rc) len = size(array,2) call MAPL_CommsSendRecv(this%layout, & - array(last , : ), len, pet_west, & - array(1 , : ), len, pet_east, & + array(last , : ), len, pet_east, & + array(1 , : ), len, pet_west, & rc=status) _VERIFY(status) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 new file mode 100644 index 00000000000..219381acb47 --- /dev/null +++ b/base/MAPL_Resource.F90 @@ -0,0 +1,360 @@ +#include "MAPL_Exceptions.h" +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +!============================================================================= +!FPP macros for repeated (type-dependent) code + +#ifdef SET_VAL +# undef SET_VAL +#endif + +#define SET_VAL(T, VAL) \ +type is (T) ;\ + if (default_is_present .and. .not. label_is_present) then ;\ + select type(default) ;\ + type is(T) ;\ + VAL = default ;\ + class default ;\ + _FAIL("Type of 'default' does not match type of 'VAL'.") ;\ + end select ;\ + else ;\ + call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, _RC) ;\ + end if + + +#ifdef SET_VALS +# undef SET_VALS +#endif + +#define SET_VALS(T, VALS) \ +type is (T) ;\ + if (default_is_present .and. .not. label_is_present) then ;\ + select type(default) ;\ + type is(T) ;\ + VALS = default ;\ + class default ;\ + _FAIL("Type of 'default' does not match type of 'VALS'.") ;\ + end select ;\ + else ;\ + call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, _RC) ;\ + end if + +#ifdef SET_STRINGS +# undef SET_STRINGS +#endif + +#define SET_STRINGS(T, TSTR, TFMT) \ +type is (T) ;\ + type_str = TSTR ;\ + val_str = intrinsic_to_string(val, TFMT) ;\ + if (present(default)) then ;\ + default_str = intrinsic_to_string(default, TFMT) ;\ + end if + +!============================================================================= + + +module MAPL_ResourceMod + + !BOP + ! !MODULE: MAPL_ResourceMod + ! + ! !DESCRIPTION: MAPL\_ResourceMod provides subroutines get scalar and array + ! resources from ESMF_Config objects. + + ! !USES: + + use ESMF + use ESMFL_Mod + use gFTL2_StringVector + use MAPL_CommsMod + use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR + use MAPL_ExceptionHandling + use MAPL_KeywordEnforcerMod + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 + + ! !PUBLIC MEMBER FUNCTIONS: + + implicit none + private + + public MAPL_GetResource_config_scalar + public MAPL_GetResource_config_array + +contains + + ! MAPL searches for labels with certain prefixes as well as just the label itself + pure function get_labels_with_prefix(label, component_name) result(labels_with_prefix) + character(len=*), intent(in) :: label + character(len=*), optional, intent(in) :: component_name + character(len=ESMF_MAXSTR) :: component_type + character(len=ESMF_MAXSTR) :: labels_with_prefix(4) + + if(present(component_name)) then + component_type = component_name(index(component_name, ":") + 1:) + + ! The order to search for labels in resource files + labels_with_prefix(1) = trim(component_name)//"_"//trim(label) + labels_with_prefix(2) = trim(component_type)//"_"//trim(label) + labels_with_prefix(3) = trim(label) + labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) + else + labels_with_prefix = '' + labels_with_prefix(1) = label + end if + + end function get_labels_with_prefix + + ! If possible, find label or label with prefix. Out: label found (logical) ! version of label found, + subroutine get_actual_label(config, label, label_is_present, actual_label, unusable, component_name, rc) + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: label + logical, intent(out) :: label_is_present + character(len=:), allocatable, intent(out) :: actual_label + class(KeywordEnforcer), optional, intent(in) :: unusable + character(len=*), optional, intent(in) :: component_name + integer, optional, intent(out) :: rc + + character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) + integer :: i + integer :: status + + _UNUSED_DUMMY(unusable) + + label_is_present = .false. + + ! If component_name is present, find label in some form in config. Else search + ! for exact label + + labels_to_try = get_labels_with_prefix(label, component_name) + + do i = 1, size(labels_to_try) + actual_label = trim(labels_to_try(i)) + if (len_trim(actual_label) == 0 ) cycle + call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, _RC) + if (label_is_present) exit + end do + + _RETURN(_SUCCESS) + end subroutine get_actual_label + + ! Find value of scalar variable in config + subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unusable, default, component_name, rc) + type(ESMF_Config), intent(inout) :: config + class(*), intent(inout) :: val + character(len=*), intent(in) :: label + logical , intent(out) :: value_is_set + class(KeywordEnforcer), optional, intent(in) :: unusable + class(*), optional, intent(in) :: default + character(len=*), optional, intent(in) :: component_name + integer, optional, intent(out) :: rc + + integer :: status, printrc + logical :: default_is_present, label_is_present + character(len=:), allocatable :: label_to_print + character(len=:), allocatable :: actual_label + + _UNUSED_DUMMY(unusable) + + value_is_set = .FALSE. + + default_is_present = present(default) + + if (default_is_present) then + _ASSERT(same_type_as(val, default), "Value and default must have same type") + end if + + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) + + ! No default and not in config, error + ! label or default must be present + if (.not. label_is_present .and. .not. default_is_present) then + value_is_set = .FALSE. + return + end if + + select type(val) + SET_VAL(integer(int32), val) + SET_VAL(integer(int64), val) + SET_VAL(real(real32), val) + SET_VAL(real(real64), val) + SET_VAL(character(len=*), val) + SET_VAL(logical, val) + class default + _FAIL( "Unupported type") + end select + + value_is_set = .TRUE. + + call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, _RC) + + ! Can set printrc to negative to not print at all + if (MAPL_AM_I_Root() .and. printrc >= 0) then + if (label_is_present) then + label_to_print = actual_label + else + label_to_print = trim(label) + end if + call print_resource(printrc, label_to_print, val, default=default, _RC) + end if + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_GetResource_config_scalar + + ! Find value of array variable in config + subroutine MAPL_GetResource_config_array(config, vals, label, value_is_set, unusable, default, component_name, rc) + type(ESMF_Config), intent(inout) :: config + class(*), intent(inout) :: vals(:) + character(len=*), intent(in) :: label + logical, intent(out) :: value_is_set + class(KeywordEnforcer), optional, intent(in) :: unusable + class(*), optional, intent(in) :: default(:) + character(len=*), optional, intent(in) :: component_name + integer, optional, intent(out) :: rc + + character(len=:), allocatable :: actual_label + integer :: status, count + logical :: label_is_present, default_is_present + + _UNUSED_DUMMY(unusable) + + value_is_set = .FALSE. + + default_is_present = present(default) + + if (default_is_present) then + _ASSERT(same_type_as(vals, default), "Value and default must have same type") + end if + + _ASSERT(present(component_name), "Component name is necessary but not present.") + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) + + ! No default and not in config, error + ! label or default must be present + if (.not. label_is_present .and. .not. default_is_present) then + value_is_set = .FALSE. + return + end if + + count = size(vals) + + select type(vals) + SET_VALS(integer(int32), vals) + SET_VALS(integer(int64), vals) + SET_VALS(real(real32), vals) + SET_VALS(real(real64), vals) + SET_VALS(character(len=*), vals) + SET_VALS(logical, vals) + class default + _FAIL( "Unsupported type") + end select + + value_is_set = .TRUE. + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_GetResource_config_array + + ! Print the resource value according to the value of printrc + ! printrc = 0 - Only print non-default values + ! printrc = 1 - Print all values + subroutine print_resource(printrc, label, val, default, rc) + integer, intent(in) :: printrc + character(len=*), intent(in) :: label + class(*), intent(in) :: val + class(*), optional, intent(in) :: default + integer, optional, intent(out) :: rc + + character(len=:), allocatable :: val_str, default_str, output_format, type_str, type_format + type(StringVector), pointer, save :: already_printed_labels => null() + integer :: status + + if (.not. associated(already_printed_labels)) then + allocate(already_printed_labels) + end if + + ! Do not print label more than once + if (.not. vector_contains_str(already_printed_labels, trim(label))) then + call already_printed_labels%push_back(trim(label)) + else + return + end if + + select type(val) + SET_STRINGS(integer(int32), "'Integer*4 '", '(i0.1)') + SET_STRINGS(integer(int64), "'Integer*8 '", '(i0.1)') + SET_STRINGS(real(real32), "'Real*4 '" , '(f0.6)') + SET_STRINGS(real(real64), "'Real*8 '" , '(f0.6)') + SET_STRINGS(logical, "'Logical '" , '(l1)' ) + SET_STRINGS(character(len=*),"'Character '", '(a)') + class default + _FAIL("Unsupported type") + end select + + output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)a" + + ! printrc = 0 - Only print non-default values + ! printrc = 1 - Print all values + if (present(default)) then + if (trim(val_str) /= trim(default_str) .or. printrc == 1) then + print output_format, trim(label), trim(val_str) + end if + else + print output_format, trim(label), trim(val_str) + end if + + _RETURN(_SUCCESS) + + end subroutine print_resource + + ! Check if vector contains string + logical function vector_contains_str(vector, string) + type(StringVector), intent(in) :: vector + character(len=*), intent(in) :: string + type(StringVectorIterator) :: iter + + iter = vector%begin() + + vector_contains_str = .false. + + do while (iter /= vector%end()) + if (trim(string) == iter%of()) then + vector_contains_str = .true. + return + end if + call iter%next() + end do + + end function vector_contains_str + + ! Convert val to string according to str_format + function intrinsic_to_string(val, str_format, rc) result(formatted_str) + class(*), intent(in) :: val + character(len=*), intent(in) :: str_format + character(len=256) :: formatted_str + integer, optional, intent(out) :: rc + + select type(val) + type is(integer(int32)) + write(formatted_str, str_format) val + type is(integer(int64)) + write(formatted_str, str_format) val + type is(real(real32)) + write(formatted_str, str_format) val + type is(real(real64)) + write(formatted_str, str_format) val + type is(logical) + write(formatted_str, str_format) val + type is(character(len=*)) + formatted_str = trim(val) + class default + _FAIL( "Unsupported type in intrinsic_to_string") + end select + + _RETURN(_SUCCESS) + + end function intrinsic_to_string + +end module MAPL_ResourceMod diff --git a/base/MAPL_SphericalGeometry.F90 b/base/MAPL_SphericalGeometry.F90 index 8cadc85c3d1..7e61564bb07 100644 --- a/base/MAPL_SphericalGeometry.F90 +++ b/base/MAPL_SphericalGeometry.F90 @@ -9,8 +9,46 @@ module MAPL_SphericalGeometry implicit none private public get_points_in_spherical_domain +public get_area_spherical_polygon contains + ! get area of spherical rectangle given the four corners + ! p4 ------ p3 + ! | | + ! | | + ! | | + ! p1 ------ p2 + function get_area_spherical_polygon(p1,p4,p2,p3) result(area) + real(real64) :: area + real(real64), intent(in) :: p1(2),p2(2),p3(2),p4(2) + + real(real64) :: e1(3),e2(3),e3(3) + real(real64) :: ang1,ang2,ang3,ang4 + + e1 = convert_to_cart(p1) + e2 = convert_to_cart(p2) + e3 = convert_to_cart(p4) + ang1 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p2) + e2 = convert_to_cart(p3) + e3 = convert_to_cart(p1) + ang2 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p3) + e2 = convert_to_cart(p4) + e3 = convert_to_cart(p2) + ang3 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p4) + e2 = convert_to_cart(p3) + e3 = convert_to_cart(p1) + ang4 = spherical_angles(e1, e2, e3) + + area = ang1 + ang2 + ang3 + ang4 - 2.0d0*MAPL_PI_R8 + + end function get_area_spherical_polygon + subroutine get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,lons,lats,ii,jj,rc) real(real64), intent(in) :: center_lats(:,:),center_lons(:,:) real(real64), intent(in) :: corner_lats(:,:),corner_lons(:,:) @@ -217,4 +255,53 @@ function vect_mag(v) result(mag) mag = sqrt(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) end function vect_mag +function spherical_angles(p1,p2,p3) result(spherical_angle) + real(real64) :: spherical_angle + real(real64), intent(in) :: p1(3),p2(3),p3(3) + + real (real64):: e1(3), e2(3), e3(3) + real (real64):: px, py, pz + real (real64):: qx, qy, qz + real (real64):: angle, ddd + integer n + + do n=1,3 + e1(n) = p1(n) + e2(n) = p2(n) + e3(n) = p3(n) + enddo + + !------------------------------------------------------------------- + ! Page 41, Silverman's book on Vector Algebra; spherical trigonmetry + !------------------------------------------------------------------- + ! Vector P: + px = e1(2)*e2(3) - e1(3)*e2(2) + py = e1(3)*e2(1) - e1(1)*e2(3) + pz = e1(1)*e2(2) - e1(2)*e2(1) + ! Vector Q: + qx = e1(2)*e3(3) - e1(3)*e3(2) + qy = e1(3)*e3(1) - e1(1)*e3(3) + qz = e1(1)*e3(2) - e1(2)*e3(1) + + ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz) + + if ( ddd <= 0.0d0 ) then + angle = 0.d0 + else + ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd) + if ( abs(ddd)>1.d0) then + angle = 0.5d0 * MAPL_PI_R8 + if (ddd < 0.d0) then + angle = MAPL_PI_R8 + else + angle = 0.d0 + end if + else + angle = acos( ddd ) + endif + endif + + spherical_angle = angle +end function + end module MAPL_SphericalGeometry diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index f964b7d7f34..3ebd68166a1 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -34,6 +34,7 @@ module MAPL_SunMod ! !PUBLIC MEMBER FUNCTIONS: public MAPL_SunOrbitCreate + public MAPL_SunOrbitCreateFromConfig public MAPL_SunOrbitCreated public MAPL_SunOrbitDestroy public MAPL_SunOrbitQuery @@ -41,6 +42,7 @@ module MAPL_SunMod public MAPL_SunGetSolarConstant public MAPL_SunGetDaylightDuration public MAPL_SunGetDaylightDurationMax + public MAPL_SunGetLocalSolarHourAngle ! !PUBLIC TYPES: @@ -55,6 +57,53 @@ module MAPL_SunMod integer, public, parameter :: MAPL_SunDailyMean = 5 integer, public, parameter :: MAPL_SunAnnualMean = 6 +! Default solar orbital system parameters (private). +! Dont change these unless you know what you are doing. +! They are appropriate for the current modern epoch circa 2000. +! ------------------------------------------------------------- + + ! Parameters of old orbital system (tabularized intercalation cycle) + ! ------------------------------------------------------------------ + real, parameter :: DEFAULT_ORBIT_ECCENTRICITY = 0.0167 + real, parameter :: DEFAULT_ORBIT_OBLIQUITY = 23.45 ! degrees + real, parameter :: DEFAULT_ORBIT_PERIHELION = 102.0 ! degrees + integer, parameter :: DEFAULT_ORBIT_EQUINOX = 80 ! days + + ! Parameters of new orbital system (analytic two-body), which allows some + ! time-varying behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. + ! ------------------------------------------------------------------------- + + ! Fixed anomalistic year length in mean solar days + real, parameter :: DEFAULT_ORB2B_YEARLEN = 365.2596 + + ! Reference date and time for orbital parameters + ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) + integer, parameter :: DEFAULT_ORB2B_REF_YYYYMMDD = 20000101 + integer, parameter :: DEFAULT_ORB2B_REF_HHMMSS = 115856 + + ! Orbital eccentricity at reference date + real, parameter :: DEFAULT_ORB2B_ECC_REF = 0.016710 + ! Rate of change of orbital eccentricity per Julian century + real, parameter :: DEFAULT_ORB2B_ECC_RATE = -4.2e-5 + + ! Earth's obliquity (axial tilt) at reference date [degrees] + real, parameter :: DEFAULT_ORB2B_OBQ_REF = 23.44 + ! Rate of change of obliquity [degrees per Julian century] + real, parameter :: DEFAULT_ORB2B_OBQ_RATE = -1.3e-2 + + ! Longitude of perihelion at reference date [degrees] + ! (from March equinox to perihelion in direction of earth's motion) + real, parameter :: DEFAULT_ORB2B_LAMBDAP_REF = 282.947 + ! Rate of change of LAMBDAP [degrees per Julian century] + ! (Combines both equatorial and ecliptic precession) + real, parameter :: DEFAULT_ORB2B_LAMBDAP_RATE = 1.7195 + + ! March Equinox date and time + ! (defaults to March 20, 2000 at 07:35:00 UTC) + integer, parameter :: DEFAULT_ORB2B_EQUINOX_YYYYMMDD = 20000320 + integer, parameter :: DEFAULT_ORB2B_EQUINOX_HHMMSS = 73500 + +! ------------------------------------------------------------- interface MAPL_SunGetInsolation module procedure SOLAR_1D @@ -758,6 +807,160 @@ end function MAPL_SunOrbitCreate !========================================================================== +!BOPI + +! !IROUTINE: MAPL_SunOrbitCreateFromConfig + +! !DESCRIPTION: + +! Like MAPL_SunOrbitCreate() but gets orbital parameters from Config CF. + +! !INTERFACE: + + function MAPL_SunOrbitCreateFromConfig ( & + CF, CLOCK, FIX_SUN, RC) result (ORBIT) + +! !ARGUMENTS: + + type (ESMF_Config), intent(INOUT) :: CF + type (ESMF_Clock), intent(IN ) :: CLOCK + logical, intent(IN ) :: FIX_SUN + integer, optional, intent(OUT ) :: RC + + type (MAPL_SunOrbit) :: ORBIT + +!EOPI + + character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreateFromConfig" + integer :: STATUS + + real :: ECC, OB, PER + integer :: EQNX + + logical :: EOT, ORBIT_ANAL2B + integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & + ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS + real :: ORB2B_YEARLEN, & + ORB2B_ECC_REF, ORB2B_ECC_RATE, & + ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & + ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE + + ! pmn: There is one orbit is per STATE, so, for example, the MAPL states of the + ! solar and land gridded components can potentially have independent solar orbits. + ! Usually these "independent orbits" will be IDENTICAL because the configuration + ! resources such as "ECCENTRICITY:" or "EOT:" will not be qualified by the name + ! of the gridded component. But for example, if the resource file specifies + ! "EOT: .FALSE." + ! but + ! "SOLAR_EOT: .TRUE." + ! then only SOLAR will have an EOT correction. The same goes for the new orbital + ! system choice ORBIT_ANAL2B. + ! A state's orbit is actually created in this routine by requesting the ORBIT + ! object. If its not already created then it will be made below. GridComps that + ! don't needed an orbit and dont request one will not have one. + + ! Parameters of standard orbital system (tabularized intercalation cycle) + ! ----------------------------------------------------------------------- + call ESMF_ConfigGetAttribute (CF, & + ECC, label="ECCENTRICITY:", & + default=DEFAULT_ORBIT_ECCENTRICITY, _RC) + + call ESMF_ConfigGetAttribute (CF, & + OB, label="OBLIQUITY:", & + default=DEFAULT_ORBIT_OBLIQUITY, _RC) + + call ESMF_ConfigGetAttribute (CF, & + PER, label="PERIHELION:", & + default=DEFAULT_ORBIT_PERIHELION, _RC) + + call ESMF_ConfigGetAttribute (CF, & + EQNX, label="EQUINOX:", & + default=DEFAULT_ORBIT_EQUINOX, _RC) + + ! Apply Equation of Time correction? + ! ---------------------------------- + call ESMF_ConfigGetAttribute (CF, & + EOT, label="EOT:", & + default=.FALSE., _RC) + + ! New orbital system (analytic two-body) allows some time-varying + ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. + ! --------------------------------------------------------------- + + call ESMF_ConfigGetAttribute (CF, & + ORBIT_ANAL2B, label="ORBIT_ANAL2B:", & + default=.FALSE., _RC) + + ! Fixed anomalistic year length in mean solar days + call ESMF_ConfigGetAttribute (CF, & + ORB2B_YEARLEN, label="ORB2B_YEARLEN:", & + default=DEFAULT_ORB2B_YEARLEN, _RC) + + ! Reference date and time for orbital parameters + call ESMF_ConfigGetAttribute (CF, & + ORB2B_REF_YYYYMMDD, label="ORB2B_REF_YYYYMMDD:", & + default=DEFAULT_ORB2B_REF_YYYYMMDD, _RC) + call ESMF_ConfigGetAttribute (CF, & + ORB2B_REF_HHMMSS, label="ORB2B_REF_HHMMSS:", & + default=DEFAULT_ORB2B_REF_HHMMSS, _RC) + + ! Orbital eccentricity at reference date + call ESMF_ConfigGetAttribute (CF, & + ORB2B_ECC_REF, label="ORB2B_ECC_REF:", & + default=DEFAULT_ORB2B_ECC_REF, _RC) + + ! Rate of change of orbital eccentricity per Julian century + call ESMF_ConfigGetAttribute (CF, & + ORB2B_ECC_RATE, label="ORB2B_ECC_RATE:", & + default=DEFAULT_ORB2B_ECC_RATE, _RC) + + ! Earth's obliquity (axial tilt) at reference date [degrees] + call ESMF_ConfigGetAttribute (CF, & + ORB2B_OBQ_REF, label="ORB2B_OBQ_REF:", & + default=DEFAULT_ORB2B_OBQ_REF, _RC) + + ! Rate of change of obliquity [degrees per Julian century] + call ESMF_ConfigGetAttribute (CF, & + ORB2B_OBQ_RATE, label="ORB2B_OBQ_RATE:", & + default=DEFAULT_ORB2B_OBQ_RATE, _RC) + + ! Longitude of perihelion at reference date [degrees] + ! (from March equinox to perihelion in direction of earth's motion) + call ESMF_ConfigGetAttribute (CF, & + ORB2B_LAMBDAP_REF, label="ORB2B_LAMBDAP_REF:", & + default=DEFAULT_ORB2B_LAMBDAP_REF, _RC) + + ! Rate of change of LAMBDAP [degrees per Julian century] + ! (Combines both equatorial and ecliptic precession) + call ESMF_ConfigGetAttribute (CF, & + ORB2B_LAMBDAP_RATE, label="ORB2B_LAMBDAP_RATE:", & + default=DEFAULT_ORB2B_LAMBDAP_RATE, _RC) + + ! March Equinox date and time + call ESMF_ConfigGetAttribute (CF, & + ORB2B_EQUINOX_YYYYMMDD, label="ORB2B_EQUINOX_YYYYMMDD:", & + default=DEFAULT_ORB2B_EQUINOX_YYYYMMDD, _RC) + call ESMF_ConfigGetAttribute (CF, & + ORB2B_EQUINOX_HHMMSS, label="ORB2B_EQUINOX_HHMMSS:", & + default=DEFAULT_ORB2B_EQUINOX_HHMMSS, _RC) + + ! create the orbit object + ORBIT = MAPL_SunOrbitCreate ( & + CLOCK, ECC, OB, PER, EQNX, & + EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & + ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & + ORB2B_ECC_REF, ORB2B_ECC_RATE, & + ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & + ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & + ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & + FIX_SUN=FIX_SUN,_RC) + + _RETURN(ESMF_SUCCESS) + + end function MAPL_SunOrbitCreateFromConfig + +!========================================================================== + !BOP ! !IROUTINE: MAPL_SunOrbitDestroy @@ -2979,4 +3182,157 @@ end subroutine MAPL_SunGetDaylightDurationMax !========================================================================== +!BOPI + +! !IROUTINE: MAPL_SunGetLocalSolarHourAngle + +! !DESCRIPTION: + +! Returns the local solar hour angle (in radians) at the single time and +! multiple longitudes specified. In order of preference, time is taken +! from TIME, if present, or else the CURRTIME of CLOCK, if present, or +! else the CURRTIME of the ORBIT's associated clock. +! +! NB: For accurate results, namely to receive the TRUE local solar hour +! angle, ensure the ORBIT has the EOT flag set true. Conversely, to get +! only the MEAN local solar hour angle, use the optional argument +! FORCE_MLSHA=.TRUE.. This will turn off the Equation of Time correction +! (for this LSHA calculation only) even if the ORBIT includes it. For +! example, in the local noon detection in the EXAMPLE below, this will +! give mean local noons that are exactly 24 hours apart at a particular +! location. But they will no longer exactly be the solar culmination +! times (the TRUE local noon) in that case. TRUE local noons are not +! exactly 24h apart because of orbital variations in length of day +! throughout the year, as described by the Equation of Time. + +! !INTERFACE: + + subroutine MAPL_SunGetLocalSolarHourAngle (ORBIT,LONS,LSHA, & + TIME,CLOCK,FORCE_MLSHA,RC) + +! !ARGUMENTS: + + type (MAPL_SunOrbit), intent(IN ) :: ORBIT + real, dimension(:), intent(IN ) :: LONS ! [radians] + real, dimension(:), intent(OUT) :: LSHA + type (ESMF_Time), optional, intent(IN ) :: TIME + type (ESMF_Clock), optional, intent(IN ) :: CLOCK + logical, optional, intent(IN ) :: FORCE_MLSHA + integer, optional, intent(OUT) :: RC + +! !EXAMPLE OF USE: +! +! ! detecting noon within the current timestep +! type (ESMF_Time) :: NOW +! type (ESMF_TimeInterval) :: DELT +! real, dimension(size(LONS)) :: LSHA0, LSHA1 +! logical, dimension(size(LONS)) :: isNoon +! call ESMF_ClockGet (CLOCK, CURRTIME=NOW, TIMESTEP=DELT, __RC__) +! call MAPL_SunGetLocalSolarHourAngle (ORBIT, LONS, LSHA0, TIME=NOW, __RC__) +! call MAPL_SunGetLocalSolarHourAngle (ORBIT, LONS, LSHA1, TIME=NOW+DELT, __RC__) +! isnoon = (LSHA0 <= 0. .and. LSHA1 > 0.) + +!EOPI + +! Locals + + character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_SunGetLocalSolarHourAngle" + integer :: STATUS + + type (ESMF_Time) :: T + real (ESMF_KIND_R8) :: days + integer :: YEAR, SEC_OF_DAY, DAY_OF_YEAR, IDAY, IDAYP1 + real :: DFRAC, GSHA + real :: ECC, OBQ, LAMBDAP + real :: OMECC, OPECC, OMSQECC, EAFAC + real :: MA, EA, dE, TA, LAMBDA + real :: RT, RM, ET + integer :: i, nits + logical :: do_EOT + + _ASSERT (MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') + + ! Which time? + if (present(TIME)) then + T = TIME + else + if (present(CLOCK)) then + call ESMF_ClockGet ( CLOCK, CURRTIME=T, _RC) + else + call ESMF_ClockGet (ORBIT%CLOCK, CURRTIME=T, _RC) + end if + end if + + ! NB: include YY and dayOfYear here so that S is seconds WITHIN a day. + ! YEAR and DAY_OF_YEAR are used within the non-ANAL2B branch anyway. + call ESMF_TimeGet (T, YY=YEAR, dayOfYear=DAY_OF_YEAR, S=SEC_OF_DAY, RC=STATUS) + _VERIFY(STATUS) + + ! fraction of day (0 at midnight) + DFRAC = real(SEC_OF_DAY) / 86400. + + ! Greenwich MEAN solar hour angle (zero at noon) + GSHA = 2. * MAPL_PI * (DFRAC - 0.5) + + ! Apply equation of time correction? + do_EOT = ORBIT%EOT + if (present(FORCE_MLSHA)) then + if (FORCE_MLSHA) do_EOT = .FALSE. + endif + if (do_EOT) then + + if (ORBIT%ANAL2B) then + + ! include time variation in orbit from reference time + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_REF, d_r8=days, _RC) + ECC = ORBIT%ORB2B_ECC_REF + days * ORBIT%ORB2B_ECC_RATE + OBQ = ORBIT%ORB2B_OBQ_REF + days * ORBIT%ORB2B_OBQ_RATE + LAMBDAP = ORBIT%ORB2B_LAMBDAP_REF + days * ORBIT%ORB2B_LAMBDAP_RATE + ! derived quantities + OMECC = 1. - ECC + OPECC = 1. + ECC + OMSQECC = OMECC * OPECC + EAFAC = sqrt(OMECC/OPECC) + ! time interval since perhelion in days + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_PERI, d_r8=days, _RC) + ! mean anomaly + MA = ORBIT%ORB2B_OMG0 * days + ! eccentric anomaly + call invert_Keplers_Newton (MA,ECC,EA,dE,nits) + ! true anomaly + TA = calcTAfromEA (EA,EAFAC) + ! celestial longitude + LAMBDA = TA + LAMBDAP + ! solar right ascension (true and mean) + RT = atan2(sin(LAMBDA)*cos(OBQ),cos(LAMBDA)) + RM = MA + LAMBDAP + ! equation of time + ET = RECT_PMPI (RM - RT) + + else + + ! get equation of time by table interpolation + YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) + IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR + IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 + ET = ORBIT%ET(IDAYP1)*DFRAC + ORBIT%ET(IDAY)*(1.-DFRAC) + + endif + + ! Gives Greenwich TRUE solar hour angle + GSHA = GSHA + ET + + end if ! EOT correction + + ! LOCAL solar hour angle + do i = 1, size(LONS) + LSHA(i) = RECT_PMPI (GSHA + LONS(i)) + end do + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_SunGetLocalSolarHourAngle + +!========================================================================== + end module MAPL_SunMod diff --git a/base/NCIO.F90 b/base/NCIO.F90 index b0660558c28..26913807f67 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -614,7 +614,7 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) type(Netcdf4_Fileformatter) , intent(IN ) :: formatter character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:,:) - type(ArrDescr) , intent(INOUT) :: ARRDES + type(ArrDescr), optional , intent(INOUT) :: ARRDES type (ClientManager), optional, intent(inout) :: oClients integer, optional , intent( OUT) :: RC @@ -623,29 +623,39 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1,1], & - global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + if (present(arrdes)) then + if (arrdes%write_restart_by_oserver) then + _ASSERT(present(oClients), "output server is needed") + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + else + do K = 1,size(A,4) + do L = 1,size(A,3) + call MAPL_VarWrite(formatter, name, A(:,:,L,K), arrdes=arrdes, & + & oClients=oClients, lev=l, offset2=k, rc=status) + _VERIFY(status) + end do + end do + end if else - do K = 1,size(A,4) do L = 1,size(A,3) - call MAPL_VarWrite(formatter, name, A(:,:,L,K), arrdes=arrdes, & + call MAPL_VarWrite(formatter, name, A(:,:,L,K), & & oClients=oClients, lev=l, offset2=k, rc=status) _VERIFY(status) end do - end do - end if + enddo + endif + _RETURN(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R4_4d @@ -706,22 +716,29 @@ subroutine MAPL_VarWriteNCpar_R4_3d(formatter, name, A, ARRDES, oClients, RC) integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + if (present(arrdes)) then + if (arrdes%write_restart_by_oserver) then + _ASSERT(present(oClients), "output server is needed") + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + else + do l=1,size(a,3) + call MAPL_VarWrite(formatter,name,A(:,:,l), arrdes=arrdes,lev=l, rc=status) + _VERIFY(status) + enddo + endif else do l=1,size(a,3) - call MAPL_VarWrite(formatter,name,A(:,:,l), arrdes=arrdes,lev=l, rc=status) + call MAPL_VarWrite(formatter,name,A(:,:,l), lev=l, rc=status) _VERIFY(status) enddo endif diff --git a/base/RegridMethods.F90 b/base/RegridMethods.F90 index 0253ab89305..33e8d23c394 100644 --- a/base/RegridMethods.F90 +++ b/base/RegridMethods.F90 @@ -18,8 +18,8 @@ module mapl_RegridMethods public :: REGRID_METHOD_CONSERVE_HFLUX public :: UNSPECIFIED_REGRID_METHOD public :: TILING_METHODS - public :: get_regrid_method - public :: translate_regrid_method + public :: regrid_method_string_to_int + public :: regrid_method_int_to_string enum, bind(c) enumerator :: REGRID_METHOD_IDENTITY @@ -41,7 +41,7 @@ module mapl_RegridMethods contains - function get_regrid_method(string_regrid_method) result(int_regrid_method) + function regrid_method_string_to_int(string_regrid_method) result(int_regrid_method) integer :: int_regrid_method character(len=*), intent(in) :: string_regrid_method @@ -78,7 +78,7 @@ function get_regrid_method(string_regrid_method) result(int_regrid_method) end select end function - function translate_regrid_method(int_regrid_method) result(string_regrid_method) + function regrid_method_int_to_string(int_regrid_method) result(string_regrid_method) integer, intent(in) :: int_regrid_method character(len=:), allocatable :: string_regrid_method diff --git a/base/RegridderSpec.F90 b/base/RegridderSpec.F90 index 0b7ca5ce385..f106fb19ac2 100644 --- a/base/RegridderSpec.F90 +++ b/base/RegridderSpec.F90 @@ -10,7 +10,7 @@ module mapl_RegridderSpec implicit none private - + public :: RegridderSpec type :: RegridderSpec @@ -25,7 +25,7 @@ module mapl_RegridderSpec procedure :: less_than generic :: operator (<) => less_than end type RegridderSpec - + interface RegridderSpec module procedure newRegridderSpec @@ -109,7 +109,7 @@ logical function less_than(a, b) integer (kind=INT64) :: a_out_id, b_out_id integer :: a_esmf_method, b_esmf_method - + select case (a%regrid_method) case (REGRID_METHOD_CONSERVE, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) a_esmf_method = REGRID_METHOD_CONSERVE @@ -141,7 +141,7 @@ logical function less_than(a, b) less_than = .true. return end if - + a_out_id = get_factory_id(a%grid_out) b_out_id = get_factory_id(b%grid_out) if (a_out_id > b_out_id) then @@ -154,7 +154,7 @@ logical function less_than(a, b) less_than = .false. return - + end function less_than end module MAPL_RegridderSpec diff --git a/cmake/mapl_acg.cmake b/cmake/mapl_acg.cmake index d37f08eafc5..fe125c68770 100644 --- a/cmake/mapl_acg.cmake +++ b/cmake/mapl_acg.cmake @@ -44,7 +44,26 @@ function (mapl_acg target specs_file) list (APPEND options ${flag} ${ARGS_${opt}}) elseif (${opt} IN_LIST ARGS_KEYWORDS_MISSING_VALUES) string (REPLACE "{component}" component_name fname ${default}) - list (APPEND generated "${component_name}_${fname}${suffix_for_generated_include_files}") + + # What the ACG does is take the specs_file and then removes the extension and then + # it removes both "_Registry" and "_StateSpecs" from the resulting string. We need to do the + # same here in CMake. + # Example: ${specs_file1} = GEOS_MyGridComp_Registry.rc + # ${specs_file2} = GEOS_MyGridComp_StateSpecs.rc + # + # ${specs_file1} -> GEOS_MyGridComp_Registry.rc -> GEOS_MyGridComp_Registry -> GEOS_MyGridComp + # ${specs_file2} -> GEOS_MyGridComp_StateSpecs.rc -> GEOS_MyGridComp_StateSpecs -> GEOS_MyGridComp + + # First get the filename without the extension + get_filename_component (specs_file_no_ext ${specs_file} NAME_WE) + + # Now remove the _Registry and _StateSpecs + string (REPLACE "_Registry" "" specs_file_base ${specs_file_no_ext}) + string (REPLACE "_StateSpecs" "" specs_file_base ${specs_file_base}) + + # Now we let CMake know the generated file will be named off of the specs_file_base + list (APPEND generated "${specs_file_base}_${fname}${suffix_for_generated_include_files}") + list (APPEND options ${flag}) endif () diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index ed77a88b2b3..e5a5f687a2e 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -134,6 +134,7 @@ module MAPL_GenericMod use MaplShared, only: SYSTEM_DSO_EXTENSION, adjust_dso_name, is_valid_dso_name, is_supported_dso_name use MaplShared, only: get_file_extension use MAPL_RunEntryPoint + use MAPL_ResourceMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT @@ -2277,10 +2278,13 @@ subroutine report_generic_profile( rc ) type (MultiColumn) :: min_multi, mean_multi, max_multi, pe_multi, n_cyc_multi type (ESMF_VM) :: vm character(1) :: empty(0) + class(Logger), pointer :: lgr call ESMF_VmGetCurrent(vm, rc=status) _VERIFY(status) + lgr => logging%get_logger('MAPL.profiler') + ! Generate stats _across_ processes covered by this timer ! Requires consistent call trees for now. @@ -2325,12 +2329,12 @@ subroutine report_generic_profile( rc ) report = reporter%generate_report(state%t_profiler) - write(OUTPUT_UNIT,*)'' - write(OUTPUT_UNIT,*)'Times for component <' // trim(comp_name) // '>' + call lgr%info('') + call lgr%info('Times for component <%a~>', trim(comp_name)) do i = 1, size(report) - write(OUTPUT_UNIT,'(a)')report(i) + call lgr%info('%a', report(i)) end do - write(OUTPUT_UNIT,*)'' + call lgr%info('') end if _RETURN(ESMF_SUCCESS) @@ -4031,20 +4035,9 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_GenericStateGet" integer :: status - real :: ECC - real :: OB - real :: PER - integer :: EQNX logical :: FIX_SUN character(len=ESMF_MAXSTR) :: gname - logical :: EOT, ORBIT_ANAL2B - integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & - ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS - real :: ORB2B_YEARLEN, & - ORB2B_ECC_REF, ORB2B_ECC_RATE, & - ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & - ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE type(MaplGrid), pointer :: temp_grid if(present(IM)) then @@ -4088,142 +4081,15 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & CF=STATE%CF endif - ! pmn: There is one orbit is per STATE, so, for example, the MAPL states of the - ! solar and land gridded components can potentially have independent solar orbits. - ! Usually these "independent orbits" will be IDENTICAL because the configuration - ! resources such as "ECCENTRICITY:" or "EOT:" will not be qualified by the name - ! of the gridded component. But for example, if the resource file specifies - ! "EOT: .FALSE." - ! but - ! "SOLAR_EOT: .TRUE." - ! then only SOLAR will have an EOT correction. The same goes for the new orbital - ! system choice ORBIT_ANAL2B. - ! A state's orbit is actually created in this routine by requesting the ORBIT - ! object. If its not already created then it will be made below. GridComps that - ! don't needed an orbit and dont request one will not have one. - if(present(ORBIT)) then if(.not.MAPL_SunOrbitCreated(STATE%ORBIT)) then - call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,rc=status) - _VERIFY(status) - if (index(gname,"DP")>0) then - FIX_SUN=.true. - else - FIX_SUN=.false. - end if - - ! Fixed parameters of standard orbital system (tabularized intercalation cycle) - ! ----------------------------------------------------------------------------- - - call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", default=0.0167, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", default=23.45, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, PER, Label="PERIHELION:", default=102.0, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", default=80, & - RC=status) - _VERIFY(status) - - ! Apply Equation of Time correction? - ! ---------------------------------- - call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., & - RC=status) - _VERIFY(status) - - ! New orbital system (analytic two-body) allows some time-varying - ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. - ! --------------------------------------------------------------- - - call MAPL_GetResource(STATE, & - ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., & - RC=status) - _VERIFY(status) - - ! Fixed anomalistic year length in mean solar days - call MAPL_GetResource(STATE, & - ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", default=365.2596, & - RC=status) - _VERIFY(status) - - ! Reference date and time for orbital parameters - ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) - call MAPL_GetResource(STATE, & - ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", default=20000101, & - RC=status) - _VERIFY(status) - call MAPL_GetResource(STATE, & - ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", default=115856, & - RC=status) - _VERIFY(status) - - ! Orbital eccentricity at reference date - call MAPL_GetResource(STATE, & - ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", default=0.016710, & - RC=status) - _VERIFY(status) - - ! Rate of change of orbital eccentricity per Julian century - call MAPL_GetResource(STATE, & - ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", default=-4.2e-5, & - RC=status) - _VERIFY(status) - - ! Earth's obliquity (axial tilt) at reference date [degrees] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", default=23.44, & - RC=status) - _VERIFY(status) - - ! Rate of change of obliquity [degrees per Julian century] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", default=-1.3e-2, & - RC=status) - _VERIFY(status) - - ! Longitude of perihelion at reference date [degrees] - ! (from March equinox to perihelion in direction of earth's motion) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", default=282.947, & - RC=status) - _VERIFY(status) - - ! Rate of change of LAMBDAP [degrees per Julian century] - ! (Combines both equatorial and ecliptic precession) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", default=1.7195, & - RC=status) - _VERIFY(status) - - ! March Equinox date and time - ! (defaults to March 20, 2000 at 07:35:00 UTC) - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", default=20000320, & - RC=status) - _VERIFY(status) - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", default=073500, & - RC=status) - _VERIFY(status) + call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) + FIX_SUN = (index(gname,"DP")>0) ! create the orbit object - STATE%ORBIT = MAPL_SunOrbitCreate(STATE%CLOCK, ECC, OB, PER, EQNX, & - EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & - ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & - ORB2B_ECC_REF, ORB2B_ECC_RATE, & - ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & - ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & - ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & - FIX_SUN=FIX_SUN,RC=status) - _VERIFY(status) + STATE%ORBIT = MAPL_SunOrbitCreateFromConfig (STATE%CF, STATE%CLOCK, FIX_SUN, _RC) end if ORBIT=STATE%ORBIT @@ -8422,22 +8288,8 @@ recursive subroutine MAPL_GenericConnCheck(GC, RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericConnCheck - - ! MAPL searches for labels with certain prefixes as well as just the label itself - pure function get_labels_with_prefix(component_name, label) result(labels_with_prefix) - character(len=*), intent(in) :: component_name, label - character(len=ESMF_MAXSTR) :: labels_with_prefix(4), component_type - - component_type = component_name(index(component_name, ":") + 1:) - - ! The order to search for labels in resource files - labels_with_prefix(1) = trim(component_name)//"_"//trim(label) - labels_with_prefix(2) = trim(component_type)//"_"//trim(label) - labels_with_prefix(3) = trim(label) - labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) - end function get_labels_with_prefix - - + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label @@ -8445,47 +8297,25 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) class(*), optional, intent(in) :: default integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) - character(len=:), allocatable :: label_to_use - integer :: i, status - logical :: label_is_present, default_is_present - - default_is_present = present(default) - - if (default_is_present) then - _ASSERT(same_type_as(val, default), "Value and default must have same type") - end if - - label_is_present = .false. - labels_to_try = get_labels_with_prefix(state%compname, label) - - do i = 1, size(labels_to_try) - label_to_use = trim(labels_to_try(i)) - call ESMF_ConfigFindLabel(state%cf, label = label_to_use, isPresent = label_is_present, rc = status) - _VERIFY(status) + logical :: value_is_set + integer :: status - if (label_is_present) then - exit - end if - end do + call MAPL_GetResource_config_scalar(state%cf, val, label, value_is_set, & + default = default, component_name = state%compname, rc = status) - if (.not. label_is_present .and. .not. default_is_present) then + if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if - if (label_is_present) then - call MAPL_GetResourceFromConfig_Scalar(state%cf,val,label_to_use,default,rc = status) - _VERIFY(status) - else - call MAPL_GetResourceFromConfig_Scalar(state%cf,val,label,default,rc = status) - _VERIFY(status) - end if + _VERIFY(status) _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label @@ -8493,102 +8323,24 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) class(*), optional, intent(in) :: default integer, optional, intent(out) :: rc - integer :: status, printrc - logical :: default_is_present, label_is_present - character(len=:), allocatable :: label_to_print - - default_is_present = present(default) + integer :: status + logical :: value_is_set - if (default_is_present) then - _ASSERT(same_type_as(val, default), "Value and default must have same type") + call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, rc = status) + + if(.not. value_is_set) then + if (present(rc)) rc = ESMF_FAILURE + return end if - call ESMF_ConfigFindLabel(config, label = label, isPresent = label_is_present, rc = status) - - select type(val) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(len=*)) - val = trim(default) - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - class default - _FAIL( "Unupported type") - end select - - call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, rc = status) _VERIFY(status) - ! Can set printrc to negative to not print at all - if (MAPL_AM_I_Root() .and. printrc >= 0) then - if (label_is_present) then - label_to_print = label - else - label_to_print = trim(label) - end if - call print_resource(printrc, label_to_print, val, default=default,rc=status) - _VERIFY(status) - end if - - _RETURN(ESMF_SUCCESS) + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromConfig_scalar - + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResource_array(state, vals, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label @@ -8596,242 +8348,23 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) class(*), optional, intent(in) :: default(:) integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) - character(len=:), allocatable :: label_to_use - integer :: i, status, count - logical :: label_is_present, default_is_present - - default_is_present = present(default) - - if (default_is_present) then - _ASSERT(same_type_as(vals, default), "Value and default must have same type") - end if - - labels_to_try = get_labels_with_prefix(state%compname, label) - label_is_present = .false. - - ! Try out the label variations to see which one exists in the ESMF_Config - do i = 1, size(labels_to_try) - label_to_use = trim(labels_to_try(i)) - - call ESMF_ConfigFindLabel(state%cf, label = label_to_use, isPresent = label_is_present, rc = status) - _VERIFY(status) - - if (label_is_present) then - exit - end if - end do - - ! No default and not in config, error - if (.not. label_is_present .and. .not. default_is_present) then + logical :: value_is_set + integer :: status + + call MAPL_GetResource_config_array(state%cf, vals, label, value_is_set, & + default = default, component_name = state%compname, rc = status) + + if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if + + _VERIFY(status) - count = size(vals) - - select type(vals) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - if (.not. label_is_present) vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real32)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(*)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - class default - _FAIL( "Unsupported type") - end select - - _RETURN(ESMF_SUCCESS) + _RETURN(_SUCCESS) end subroutine MAPL_GetResource_array - - subroutine print_resource(printrc, label, val, default, rc) - integer, intent(in) :: printrc - character(len=*), intent(in) :: label - class(*), intent(in) :: val - class(*), optional, intent(in) :: default - integer, optional, intent(out) :: rc - - character(len=:), allocatable :: val_str, default_str, output_format, type_str, type_format - type(StringVector), pointer, save :: already_printed_labels => null() - - if (.not. associated(already_printed_labels)) then - allocate(already_printed_labels) - end if - - ! Do not print label more than once - if (.not. vector_contains_str(already_printed_labels, trim(label))) then - call already_printed_labels%push_back(trim(label)) - else - return - end if - - select type(val) - type is(integer(int32)) - type_str = "'Integer*4 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(integer(int64)) - type_str = "'Integer*8 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real32)) - type_str = "'Real*4 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real64)) - type_str = "'Real*8 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(logical) - type_str = "'Logical '" - type_format = '(l1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(character(len=*)) - type_str = "'Character '" - val_str = trim(val) - if (present(default)) then - default_str = intrinsic_to_string(default, 'a') - end if - class default - _FAIL("Unsupported type") - end select - - output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)" - - ! printrc = 0 - Only print non-default values - ! printrc = 1 - Print all values - if (present(default)) then - if (trim(val_str) /= trim(default_str) .or. printrc == 1) then - print output_format, trim(label), trim(val_str) - end if - else - print output_format, trim(label), trim(val_str) - end if - - contains - - logical function vector_contains_str(vector, string) - type(StringVector), intent(in) :: vector - character(len=*), intent(in) :: string - type(StringVectorIterator) :: iter - - iter = vector%begin() - - vector_contains_str = .false. - - if (vector%size() /= 0) then - do while (iter /= vector%end()) - if (trim(string) == iter%get()) then - vector_contains_str = .true. - return - end if - call iter%next() - end do - end if - - end function vector_contains_str - - end subroutine print_resource - - - function intrinsic_to_string(val, str_format, rc) result(formatted_str) - class(*), intent(in) :: val - character(len=*), intent(in) :: str_format - character(len=256) :: formatted_str - integer, optional, intent(out) :: rc - - select type(val) - type is(integer(int32)) - write(formatted_str, str_format) val - type is(integer(int64)) - write(formatted_str, str_format) val - type is(real(real32)) - write(formatted_str, str_format) val - type is(real(real64)) - write(formatted_str, str_format) val - type is(logical) - write(formatted_str, str_format) val - type is(character(len=*)) - formatted_str = trim(val) - class default - _FAIL( "Unsupported type in intrinsic_to_string") - end select - - end function intrinsic_to_string - - - integer function MAPL_GetNumSubtiles(STATE, RC) type (MAPL_MetaComp), intent(INOUT) :: STATE integer , optional, intent( OUT) :: RC diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 624257ffdb5..438107c6a54 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -26,11 +26,11 @@ module MAPL_CapMod character(:), allocatable :: name procedure(), nopass, pointer :: set_services => null() logical :: non_dso = .false. - integer :: comm_world + integer :: comm_world integer :: rank integer :: npes_member character(:), allocatable :: root_dso - + type (MAPL_CapOptions), allocatable :: cap_options ! misc logical :: mpi_already_initialized = .false. @@ -60,7 +60,7 @@ module MAPL_CapMod procedure :: get_cap_gc procedure :: get_cap_rc_file procedure :: get_egress_file - + end type MAPL_Cap interface MAPL_Cap @@ -85,7 +85,7 @@ function new_MAPL_Cap_from_set_services(name, set_services, unusable, cap_option class (KeywordEnforcer), optional, intent(in) :: unusable type ( MAPL_CapOptions), optional, intent(in) :: cap_options integer, optional, intent(out) :: rc - integer :: status + integer :: status cap%name = name cap%set_services => set_services @@ -112,7 +112,7 @@ function new_MAPL_Cap_from_set_services(name, set_services, unusable, cap_option rc=status) _VERIFY(status) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) end function new_MAPL_Cap_from_set_services @@ -123,7 +123,7 @@ function new_MAPL_Cap_from_dso(name, unusable, cap_options, rc) result(cap) class (KeywordEnforcer), optional, intent(in) :: unusable type ( MAPL_CapOptions), optional, intent(in) :: cap_options integer, optional, intent(out) :: rc - integer :: status + integer :: status cap%name = name @@ -148,12 +148,12 @@ function new_MAPL_Cap_from_dso(name, unusable, cap_options, rc) result(cap) rc=status) _VERIFY(status) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) end function new_MAPL_Cap_from_dso - + ! 3. Run the ensemble (default is 1 member) ! 4. Finalize MPI if initialized locally. subroutine run(this, unusable, rc) @@ -162,7 +162,7 @@ subroutine run(this, unusable, rc) integer, optional, intent(out) :: rc integer :: status ! - + _UNUSED_DUMMY(unusable) @@ -172,7 +172,7 @@ subroutine run(this, unusable, rc) _RETURN(_SUCCESS) end subroutine run - + ! This layer splits the communicator to support running a ! multi-member ensemble. @@ -185,7 +185,7 @@ subroutine run_ensemble(this, unusable, rc) integer :: subcommunicator _UNUSED_DUMMY(unusable) - + subcommunicator = this%create_member_subcommunicator(this%comm_world, rc=status); _VERIFY(status) if (subcommunicator /= MPI_COMM_NULL) then call this%initialize_io_clients_servers(subcommunicator, rc = status); _VERIFY(status) @@ -195,7 +195,7 @@ subroutine run_ensemble(this, unusable, rc) end if _RETURN(_SUCCESS) - + end subroutine run_ensemble @@ -214,7 +214,7 @@ subroutine finalize_io_clients_servers(this, unusable, rc) end select call this%cap_server%finalize() _RETURN(_SUCCESS) - + end subroutine finalize_io_clients_servers subroutine initialize_io_clients_servers(this, comm, unusable, rc) @@ -241,14 +241,14 @@ subroutine initialize_io_clients_servers(this, comm, unusable, rc) _RETURN(_SUCCESS) end subroutine initialize_io_clients_servers - + ! This layer splits the communicator to support separate i/o servers ! and runs the model via a CapGridComp. subroutine run_member(this, rc) use MAPL_CFIOMod class (MAPL_Cap), intent(inout) :: this integer, optional, intent(out) :: rc - + integer :: status type(SplitCommunicator) :: split_comm @@ -257,7 +257,7 @@ subroutine run_member(this, rc) case('model') call this%run_model(comm=split_comm%get_subcommunicator(), rc=status); _VERIFY(status) end select - + _RETURN(_SUCCESS) end subroutine run_member @@ -273,7 +273,7 @@ subroutine run_model(this, comm, unusable, rc) integer(kind=INT64) :: start_tick, stop_tick, tick_rate integer :: status class(Logger), pointer :: lgr - + _UNUSED_DUMMY(unusable) call start_timer() @@ -306,7 +306,6 @@ subroutine run_model(this, comm, unusable, rc) _VERIFY(status) call stop_timer() - ! W.J note : below reporting will be remove soon call report_throughput() _RETURN(_SUCCESS) @@ -336,14 +335,14 @@ subroutine report_throughput(rc) model_days_per_day = model_duration / wall_time - lgr => logging%get_logger('MAPL') + lgr => logging%get_logger('MAPL.profiler') call lgr%info("Model Throughput: %f12.3 days per day", model_days_per_day) end if - + end subroutine report_throughput end subroutine run_model - + subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) class(MAPL_Cap), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -357,7 +356,7 @@ subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) if (this%non_dso) then call MAPL_CapGridCompCreate(this%cap_gc, this%get_cap_rc_file(), & this%name, this%get_egress_file(), n_run_phases=n_run_phases, root_set_services = this%set_services,rc=status) - else + else _ASSERT(this%cap_options%root_dso /= 'none',"No set services specified, must pass a dso") call MAPL_CapGridCompCreate(this%cap_gc, this%get_cap_rc_file(), & this%name, this%get_egress_file(), n_run_phases=n_run_phases, root_dso = this%cap_options%root_dso,rc=status) @@ -365,7 +364,7 @@ subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) _VERIFY(status) _RETURN(_SUCCESS) end subroutine initialize_cap_gc - + subroutine step_model(this, rc) class(MAPL_Cap), intent(inout) :: this @@ -374,7 +373,7 @@ subroutine step_model(this, rc) call this%cap_gc%step(rc = status); _VERIFY(status) _RETURN(_SUCCESS) end subroutine step_model - + subroutine rewind_model(this, time, rc) class(MAPL_Cap), intent(inout) :: this type(ESMF_Time), intent(inout) :: time @@ -382,14 +381,14 @@ subroutine rewind_model(this, time, rc) integer :: status call this%cap_gc%rewind_clock(time,rc = status); _VERIFY(status) _RETURN(_SUCCESS) - end subroutine rewind_model + end subroutine rewind_model integer function create_member_subcommunicator(this, comm, unusable, rc) result(subcommunicator) class (MAPL_Cap), intent(inout) :: this integer, intent(in) :: comm class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + type (SplitCommunicator) :: split_comm integer :: status @@ -397,7 +396,7 @@ integer function create_member_subcommunicator(this, comm, unusable, rc) result( !!$ external :: chdir _UNUSED_DUMMY(unusable) - + subcommunicator = MPI_COMM_NULL ! in case of failure this%splitter = SimpleCommSplitter(comm, this%cap_options%n_members, this%npes_member, base_name=this%cap_options%ensemble_subdir_prefix) split_comm = this%splitter%split(rc=status); _VERIFY(status) @@ -408,9 +407,9 @@ integer function create_member_subcommunicator(this, comm, unusable, rc) result( status = c_chdir(dir_name) _VERIFY(status) end if - + _RETURN(_SUCCESS) - + end function create_member_subcommunicator @@ -459,13 +458,13 @@ subroutine chdir(path, err) character(*) :: path integer, optional, intent(out) :: err integer :: loc_err - + loc_err = c_chdir(path//c_null_char) - + if (present(err)) err = loc_err - + end subroutine chdir - + subroutine finalize_mpi(this, unusable, rc) class (MAPL_Cap), intent(in) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -488,7 +487,7 @@ function get_npes_model(this) result(npes_model) integer :: npes_model npes_model = this%cap_options%npes_model end function get_npes_model - + function get_comm_world(this) result(comm_world) class(MAPL_Cap), intent(in) :: this integer :: comm_world diff --git a/gridcomps/Cap/MAPL_CapGridComp.F90 b/gridcomps/Cap/MAPL_CapGridComp.F90 index 9bad9565223..8145f6c19d7 100644 --- a/gridcomps/Cap/MAPL_CapGridComp.F90 +++ b/gridcomps/Cap/MAPL_CapGridComp.F90 @@ -1348,7 +1348,7 @@ subroutine print_throughput(rc) LOOP_THROUGHPUT,INST_THROUGHPUT,RUN_THROUGHPUT,HRS_R,MIN_R,SEC_R,& mem_committed_percent,mem_used_percent 1000 format(1x,'AGCM Date: ',i4.4,'/',i2.2,'/',i2.2,2x,'Time: ',i2.2,':',i2.2,':',i2.2, & - 2x,'Throughput(days/day)[Avg Tot Run]: ',f12.1,1x,f12.1,1x,f12.1,2x,'TimeRemaining(Est) ',i3.3,':'i2.2,':',i2.2,2x, & + 2x,'Throughput(days/day)[Avg Tot Run]: ',f12.1,1x,f12.1,1x,f12.1,2x,'TimeRemaining(Est) ',i3.3,':',i2.2,':',i2.2,2x, & f5.1,'% : ',f5.1,'% Mem Comm:Used') _RETURN(_SUCCESS) @@ -1453,19 +1453,32 @@ subroutine set_grid(this, grid, unusable, lm, grid_type, rc) type(ESMF_Grid) :: mapl_grid type(ExternalGridFactory) :: external_grid_factory integer :: status + character(len=ESMF_MAXSTR):: grid_type_ + _UNUSED_DUMMY(unusable) external_grid_factory = ExternalGridFactory(grid=grid, lm=lm, _RC) mapl_grid = grid_manager%make_grid(external_grid_factory, _RC) ! grid_type is an optional parameter that allows GridType to be set explicitly. + call ESMF_ConfigGetAttribute(this%cf_root, value = grid_type_, Label="GridType:", default="", _RC) if (present(grid_type)) then + if(grid_type_ /= "") then + _ASSERT(grid_type_ == grid_type, "The grid types don't match") + endif if (grid_manager%is_valid_prototype(grid_type)) then call ESMF_AttributeSet(mapl_grid, 'GridType', grid_type, _RC) else _RETURN(_FAILURE) end if - end if + else if (grid_type_ /= "") then + if (grid_manager%is_valid_prototype(grid_type_)) then + call ESMF_AttributeSet(mapl_grid, 'GridType', grid_type_, _RC) + else + _RETURN(_FAILURE) + end if + endif + call ESMF_GridCompSet(this%gc, grid=mapl_grid, _RC) _RETURN(_SUCCESS) diff --git a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 index 6c78d49c06f..f84d2936eaf 100644 --- a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 +++ b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 @@ -54,7 +54,7 @@ function new_ExtDataOldTypesCreator(config_file,current_time,unusable,rc ) resul _RETURN(_SUCCESS) end function new_ExtDataOldTypesCreator - + subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusable,rc) class(ExtDataOldTypesCreator), intent(inout) :: this character(len=*), intent(in) :: item_name @@ -77,7 +77,7 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa _UNUSED_DUMMY(unusable) rule => this%rule_map%at(trim(item_name)) time_sample => this%sample_map%at(rule%sample_key) - + if(.not.associated(time_sample)) then call default_time_sample%set_defaults() time_sample=>default_time_sample @@ -106,14 +106,14 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa primary_item%fileVars%itemType = ItemTypeScalar primary_item%fileVars%xname = trim(rule%file_var) end if - + ! regrid method if (index(rule%regrid_method,"FRACTION;")>0) then semi_pos = index(rule%regrid_method,";") read(rule%regrid_method(semi_pos+1:),*) primary_item%fracVal primary_item%trans = REGRID_METHOD_FRACTION else - primary_item%trans = get_regrid_method(rule%regrid_method) + primary_item%trans = regrid_method_string_to_int(rule%regrid_method) end if _ASSERT(primary_item%trans/=UNSPECIFIED_REGRID_METHOD,"improper regrid method chosen") @@ -131,7 +131,7 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa call primary_item%update_freq%create_from_parameters(time_sample%refresh_time, & time_sample%refresh_frequency, time_sample%refresh_offset, time, clock, _RC) - disable_interpolation = .not.time_sample%time_interpolation + disable_interpolation = .not.time_sample%time_interpolation exact = time_sample%exact call primary_item%modelGridFields%comp1%set_parameters(linear_trans=rule%linear_trans,disable_interpolation=disable_interpolation,exact=exact) @@ -185,7 +185,7 @@ subroutine fillin_derived(this,item_name,derived_item,time,clock,unusable,rc) _UNUSED_DUMMY(unusable) rule => this%derived_map%at(trim(item_name)) - + derived_item%name = trim(item_name) derived_item%expression = rule%expression if (allocated(rule%sample_key)) then @@ -204,7 +204,7 @@ subroutine fillin_derived(this,item_name,derived_item,time,clock,unusable,rc) end if _RETURN(_SUCCESS) - + end subroutine fillin_derived end module MAPL_ExtDataOldTypesCreator diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 0a63f2d548b..33befb7b704 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -156,44 +156,29 @@ subroutine AddGrid(this,output_grids,resolution,rc) im_world=resolution(1) jm_world=resolution(2) - cfg = MAPL_ConfigCreate(rc=status) - _VERIFY(status) + cfg = MAPL_ConfigCreate(_RC) if (resolution(2)==resolution(1)*6) then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) else - call MAPL_MakeDecomposition(nx,ny,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,_RC) end if - call MAPL_ConfigSetAttribute(cfg,value=nx, label=trim(tlabel)//".NX:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=ny, label=trim(tlabel)//".NY:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value=nx, label=trim(tlabel)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=ny, label=trim(tlabel)//".NY:",_RC) if (resolution(2)==resolution(1)*6) then - call MAPL_ConfigSetAttribute(cfg,value="Cubed-Sphere", label=trim(tlabel)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=6, label=trim(tlabel)//".NF:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value="Cubed-Sphere", label=trim(tlabel)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=6, label=trim(tlabel)//".NF:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",_RC) else - call MAPL_ConfigSetAttribute(cfg,value="LatLon", label=trim(tlabel)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=jm_world,label=trim(tlabel)//".JM_WORLD:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value='PC', label=trim(tlabel)//".POLE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value='DC', label=trim(tlabel)//".DATELINE:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value="LatLon", label=trim(tlabel)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=jm_world,label=trim(tlabel)//".JM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cfg,value='PC', label=trim(tlabel)//".POLE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value='DC', label=trim(tlabel)//".DATELINE:",_RC) end if - output_grid = grid_manager%make_grid(cfg,prefix=trim(tlabel)//'.',rc=status) - _VERIFY(status) + output_grid = grid_manager%make_grid(cfg,prefix=trim(tlabel)//'.',_RC) - factory => grid_manager%get_factory(output_grid,rc=status) - _VERIFY(status) + factory => grid_manager%get_factory(output_grid,_RC) this%output_grid_label = factory%generate_grid_name() lgrid => output_grids%at(trim(this%output_grid_label)) if (.not.associated(lgrid)) call output_grids%insert(this%output_grid_label,output_grid) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 8ec9f57c8f3..a54e5a90817 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -39,7 +39,7 @@ module MAPL_HistoryGridCompMod use MAPL_GriddedIOitemVectorMod use MAPL_GriddedIOitemMod use pFIO_ClientManagerMod, only: o_Clients - use pFIO_DownbitMod, only: pFIO_DownBit + use MAPL_DownbitMod use pFIO_ConstantsMod use HistoryTrajectoryMod use MAPL_StringTemplate @@ -151,35 +151,28 @@ subroutine SetServices ( gc, rc ) ! Register services for this component ! ------------------------------------ - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_WRITERESTART, RecordRestart, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_WRITERESTART, RecordRestart, _RC) ! Allocate an instance of the private internal state... !------------------------------------------------------ - allocate(internal_state, stat=status) - _VERIFY(status) + allocate(internal_state, _STAT) ! and save its pointer in the GC !------------------------------- wrap%ptr => internal_state call ESMF_GridCompSetInternalState(gc, wrap, status) - _VERIFY(status) ! Generic Set Services ! -------------------- - call MAPL_GenericSetServices ( gc,RC=STATUS ) - _VERIFY(STATUS) + call MAPL_GenericSetServices ( gc,_RC ) _RETURN(ESMF_SUCCESS) @@ -434,12 +427,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _UNUSED_DUMMY(dumexport) - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr call ESMF_UserCompGetInternalState(GC, 'MAPL_LocStreamList', & @@ -448,13 +439,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) lsaddr_ptr => lswrap%ptr%lsaddr_ptr end if - call ESMF_GridCompGet(gc, vm=vm, rc=status) - _VERIFY(status) + call ESMF_GridCompGet(gc, vm=vm, _RC) - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) - call ESMF_VMGet (VM, localpet=MYPE, petcount=NPES, RC=STATUS) - _VERIFY(STATUS) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet (VM, localpet=MYPE, petcount=NPES, _RC) IntState%mype = mype IntState%npes = npes @@ -462,10 +450,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Clock StartTime for Default ref_date, ref_time ! -------------------------------------------------- - call ESMF_ClockGet ( clock, calendar=cal, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, currTime=CurrTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StartTime=StartTime,rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_TimeGet ( StartTime, TimeString=string ,rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_ClockGet ( clock, calendar=cal, _RC ) + call ESMF_ClockGet ( clock, currTime=CurrTime, _RC ) + call ESMF_ClockGet ( clock, StartTime=StartTime,_RC ) + call ESMF_TimeGet ( StartTime, TimeString=string ,_RC ) read(string( 1: 4),'(i4.4)') year read(string( 6: 7),'(i2.2)') month @@ -477,7 +465,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) nymd0 = year*10000 + month*100 + day nhms0 = hour*10000 + minute*100 + second - call ESMF_TimeGet ( CurrTime, TimeString=string ,rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_TimeGet ( CurrTime, TimeString=string ,_RC ) read(string( 1: 4),'(i4.4)') year read(string( 6: 7),'(i2.2)') month @@ -497,17 +485,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Read User-Supplied History Lists from Config File ! ------------------------------------------------- - call ESMF_GridCompGet( gc, config=config, rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_GridCompGet( gc, config=config, _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expsrc, & - label ='EXPSRC:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPSRC:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expid, & - label ='EXPID:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPID:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expdsc, & - label ='EXPDSC:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPDSC:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%global_atts%institution, & label ='INSTITUTION:', default='NASA Global Modeling and Assimilation Office', _RC) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%global_atts%references, & @@ -522,18 +507,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label ='SOURCE:', & default=trim(INTSTATE%expsrc) // ' experiment_id: ' // trim(INTSTATE%expid), _RC) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%CoresPerNode, & - label ='CoresPerNode:', default=min(npes,8), rc=status ) - _VERIFY(STATUS) + label ='CoresPerNode:', default=min(npes,8), _RC ) call ESMF_ConfigGetAttribute ( config, value=disableSubVmChecks, & - label ='DisableSubVmChecks:', default=.false., rc=status ) - _VERIFY(STATUS) + label ='DisableSubVmChecks:', default=.false., _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%AvoidRootNodeThreshold, & - label ='AvoidRootNodeThreshold:', default=1024, rc=status ) - _VERIFY(STATUS) + label ='AvoidRootNodeThreshold:', default=1024, _RC ) call ESMF_ConfigGetAttribute(config, value=cFileOrder, & - label='FileOrder:', default='ABC', rc=status) - _VERIFY(STATUS) + label='FileOrder:', default='ABC', _RC) call ESMF_ConfigGetAttribute(config, value=intState%allow_overwrite, & label='Allow_Overwrite:', default=.false., _RC) create_mode = PFIO_NOCLOBBER ! defaut no overwrite @@ -550,21 +531,16 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigGetAttribute(config, value=intstate%integer_time,label="IntegerTime:", default=.false.,_RC) call ESMF_ConfigGetAttribute(config, value=IntState%collectionWriteSplit, & - label = 'CollectionWriteSplit:', default=0, rc=status) - _VERIFY(status) + label = 'CollectionWriteSplit:', default=0, _RC) call ESMF_ConfigGetAttribute(config, value=IntState%serverSizeSplit, & - label = 'ServerSizeSplit:', default=0, rc=status) - _VERIFY(status) + label = 'ServerSizeSplit:', default=0, _RC) call o_Clients%split_server_pools(n_server_split = IntState%serverSizeSplit, & - n_hist_split = IntState%collectionWriteSplit,rc=status) - _VERIFY(status) + n_hist_split = IntState%collectionWriteSplit,_RC) call ESMF_ConfigGetAttribute(config, value=snglcol, & - label='SINGLE_COLUMN:', default=0, rc=status) - _VERIFY(STATUS) + label='SINGLE_COLUMN:', default=0, _RC) call ESMF_ConfigGetAttribute(config, value=intstate%version, & - label='VERSION:', default=0, rc=status) - _VERIFY(STATUS) + label='VERSION:', default=0, _RC) if( MAPL_AM_I_ROOT() ) then print * print *, 'EXPSRC:',trim(INTSTATE%expsrc) @@ -581,12 +557,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) print *, '-------------------------' endif - call ESMF_ConfigFindLabel ( config,'COLLECTIONS:',rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel ( config,'COLLECTIONS:',_RC ) tend = .false. nlist = 0 - allocate(IntState%list(nlist), stat=status) - _VERIFY(STATUS) + allocate(IntState%list(nlist), _STAT) do while (.not.tend) call ESMF_ConfigGetAttribute ( config,value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! if (tmpstring /= '') then @@ -596,16 +570,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call IntState%collections%push_back(collection) nlist = nlist + 1 - allocate( list(nlist), stat=status ) - _VERIFY(STATUS) + allocate( list(nlist), _STAT ) list(1:nlist-1)=IntState%list list(nlist)%collection = tmpstring list(nlist)%filename = list(nlist)%collection deallocate(IntState%list) IntState%list => list end if - call ESMF_ConfigNextLine ( config,tableEnd=tend,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo if (nlist == 0) then @@ -619,40 +591,32 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) integer :: nl character(len=60) :: grid_type - call ESMF_ConfigFindLabel ( config,'GRID_LABELS:',rc=STATUS ) - _VERIFY(status) + call ESMF_ConfigFindLabel ( config,'GRID_LABELS:',_RC ) tend = .false. do while (.not.tend) call ESMF_ConfigGetAttribute ( config,value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! if (tmpstring /= '') then call IntState%output_grids%insert(trim(tmpString), output_grid) end if - call ESMF_ConfigNextLine ( config,tableEnd=tend,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo iter = IntState%output_grids%begin() do while (iter /= IntState%output_grids%end()) key => iter%key() - call ESMF_ConfigGetAttribute(config, value=grid_type, label=trim(key)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call ESMF_ConfigFindLabel(config,trim(key)//".NX:",isPresent=hasNX,rc=status) - _VERIFY(status) - call ESMF_ConfigFindLabel(config,trim(key)//".NY:",isPresent=hasNY,rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(config, value=grid_type, label=trim(key)//".GRID_TYPE:",_RC) + call ESMF_ConfigFindLabel(config,trim(key)//".NX:",isPresent=hasNX,_RC) + call ESMF_ConfigFindLabel(config,trim(key)//".NY:",isPresent=hasNY,_RC) if ((.not.hasNX) .and. (.not.hasNY)) then if (trim(grid_type)=='Cubed-Sphere') then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) else - call MAPL_MakeDecomposition(nx,ny,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,_RC) end if - call MAPL_ConfigSetAttribute(config, value=nx,label=trim(key)//".NX:",rc=status) - call MAPL_ConfigSetAttribute(config, value=ny,label=trim(key)//".NY:",rc=status) + call MAPL_ConfigSetAttribute(config, value=nx,label=trim(key)//".NX:",_RC) + call MAPL_ConfigSetAttribute(config, value=ny,label=trim(key)//".NY:",_RC) end if - output_grid = grid_manager%make_grid(config, prefix=key//'.', rc=status) - _VERIFY(status) + output_grid = grid_manager%make_grid(config, prefix=key//'.', _RC) call IntState%output_grids%set(key, output_grid) call iter%next() end do @@ -660,8 +624,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if if (intstate%version >= 2) then - call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', rc=status) - _VERIFY(status) + call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', _RC) table_end = .false. do while (.not. table_end) call ESMF_ConfigGetAttribute ( config, value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! @@ -671,28 +634,23 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call intstate%field_sets%insert(trim(tmpString), field_set) deallocate(field_set) end if - call ESMF_ConfigNextLine ( config,tableEnd=table_end,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( config,tableEnd=table_end,_RC ) enddo field_set_iter = intState%field_sets%begin() do while (field_set_iter /= intState%field_sets%end()) key => field_set_iter%key() field_set => field_set_iter%value() - call parse_fields(config, key, field_set, rc=status) - _VERIFY(status) + call parse_fields(config, key, field_set, _RC) call field_set_iter%next() end do end if - allocate(IntState%Regrid(nlist), stat=STATUS) - _VERIFY(STATUS) - allocate( Vvarn(nlist), stat=STATUS) - _VERIFY(STATUS) - allocate(INTSTATE%STAMPOFFSET(nlist), stat=status) - _VERIFY(STATUS) + allocate(IntState%Regrid(nlist), _STAT) + allocate( Vvarn(nlist), _STAT) + allocate(INTSTATE%STAMPOFFSET(nlist), _STAT) ! We are parsing HISTORY config file to split each collection into separate RC ! ---------------------------------------------------------------------------- @@ -700,16 +658,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( MAPL_AM_I_ROOT(vm) ) then call ESMF_ConfigGetAttribute(config, value=HIST_CF, & - label="HIST_CF:", default="HIST.rc", RC=STATUS ) - _VERIFY(STATUS) - unitr = GETFILE(HIST_CF, FORM='formatted', RC=status) - _VERIFY(STATUS) + label="HIST_CF:", default="HIST.rc", _RC ) + unitr = GETFILE(HIST_CF, FORM='formatted', _RC) ! for each collection do n = 1, nlist rewind(unitr) string = trim( list(n)%collection ) // '.' - unitw = GETFILE(trim(string)//'rcx', FORM='formatted', RC=status) + unitw = GETFILE(trim(string)//'rcx', FORM='formatted', _RC) match = .false. contLine = .false. @@ -732,18 +688,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end do 1234 continue - call free_file(unitw, rc=status) - _VERIFY(STATUS) + call free_file(unitw, _RC) end do - call free_file(unitr, rc=status) - _VERIFY(STATUS) + call free_file(unitr, _RC) end if - call ESMF_VMbarrier(vm, RC=status) - _VERIFY(STATUS) + call ESMF_VMbarrier(vm, _RC) ! Initialize History Lists ! ------------------------ @@ -764,20 +717,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%splitField = .false. list(n)%regex = .false. - cfg = ESMF_ConfigCreate(rc=STATUS) - _VERIFY(STATUS) + cfg = ESMF_ConfigCreate(_RC) - call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', rc=status) - _VERIFY(STATUS) + call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', _RC) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%template, default="", & - label=trim(string) // 'template:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'template:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%format,default='flat', & - label=trim(string) // 'format:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'format:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%mode,default='instantaneous', & - label=trim(string) // 'mode:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'mode:' ,_RC ) ! Fill the global attributes @@ -786,8 +734,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%global_atts%filename = list(n)%filename call ESMF_ConfigGetAttribute ( cfg, value=list(n)%global_atts%descr, & default=INTSTATE%expdsc, & - label=trim(string) // 'descr:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'descr:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%global_atts%comment, & default=INTSTATE%global_atts%comment, & label=trim(string) // 'comment:' ,_RC) @@ -808,69 +755,53 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label=trim(string) // 'source:' ,_RC) call ESMF_ConfigGetAttribute ( cfg, mntly, default=0, & - label=trim(string) // 'monthly:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'monthly:',_RC ) list(n)%monthly = (mntly /= 0) call ESMF_ConfigGetAttribute ( cfg, spltFld, default=0, & - label=trim(string) // 'splitField:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'splitField:',_RC ) list(n)%splitField = (spltFld /= 0) call ESMF_ConfigGetAttribute ( cfg, useRegex, default=0, & - label=trim(string) // 'UseRegex:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'UseRegex:',_RC ) list(n)%regex = (useRegex /= 0) call ESMF_ConfigGetAttribute ( cfg, list(n)%frequency, default=060000, & - label=trim(string) // 'frequency:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'frequency:',_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%acc_interval, default=list(n)%frequency, & - label=trim(string) // 'acc_interval:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'acc_interval:',_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%ref_date, default=nymdc, & - label=trim(string) // 'ref_date:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'ref_date:',_RC ) _ASSERT(is_valid_date(list(n)%ref_date),'Invalid ref_date') call ESMF_ConfigGetAttribute ( cfg, list(n)%ref_time, default=000000, & - label=trim(string) // 'ref_time:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'ref_time:',_RC ) _ASSERT(is_valid_time(list(n)%ref_time),'Invalid ref_time') call ESMF_ConfigGetAttribute ( cfg, list(n)%end_date, default=-999, & - label=trim(string) // 'end_date:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'end_date:',_RC ) if (list(n)%end_date /= -999) then _ASSERT(is_valid_date(list(n)%end_date),'Invalid end_date') end if call ESMF_ConfigGetAttribute ( cfg, list(n)%end_time, default=-999, & - label=trim(string) // 'end_time:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'end_time:',_RC ) if (list(n)%end_time /= -999) then _ASSERT(is_valid_time(list(n)%end_time),'Invalid end_time') end if call ESMF_ConfigGetAttribute ( cfg, list(n)%duration, default=list(n)%frequency, & - label=trim(string) // 'duration:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'duration:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%verbose, default=0, & - label=trim(string) // 'verbose:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'verbose:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%vscale, default=1.0, & - label=trim(string) // 'vscale:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'vscale:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%vunit, default="", & - label=trim(string) // 'vunit:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'vunit:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%nbits_to_keep, default=MAPL_NBITS_NOT_SET, & - label=trim(string) // 'nbits:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'nbits:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%deflate, default=0, & - label=trim(string) // 'deflate:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'deflate:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%quantize_algorithm_string, default='NONE', & - label=trim(string) // 'quantize_algorithm:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'quantize_algorithm:' ,_RC ) ! Uppercase the algorithm string just to allow for any case uppercase_algorithm = ESMF_UtilStringUpperCase(list(n)%quantize_algorithm_string,_RC) @@ -888,8 +819,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end select call ESMF_ConfigGetAttribute ( cfg, list(n)%quantize_level, default=0, & - label=trim(string) // 'quantize_level:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'quantize_level:' ,_RC ) ! If nbits_to_keep < MAPL_NBITS_UPPER_LIMIT (24) and quantize_algorithm greater than 0, then a user might be doing different ! shaving algorithms. We do not allow this @@ -909,8 +839,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) tm_default = -1 call ESMF_ConfigGetAttribute ( cfg, list(n)%tm, default=tm_default, & - label=trim(string) // 'tm:', rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'tm:', _RC ) call ESMF_ConfigFindLabel ( cfg, label=trim(string) // 'conservative:',isPresent=has_conservative_keyword,_RC) call ESMF_ConfigFindLabel ( cfg, label=trim(string) // 'regrid_method:',isPresent=has_regrid_keyword,_RC) @@ -919,8 +848,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%regrid_method = REGRID_METHOD_BILINEAR if (has_conservative_keyword) then call ESMF_ConfigGetAttribute ( cfg, list(n)%regrid_method, default=0, & - label=trim(string) // 'conservative:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'conservative:' ,_RC ) if (list(n)%regrid_method==0) then list(n)%regrid_method=REGRID_METHOD_BILINEAR else if (list(n)%regrid_method==1) then @@ -929,23 +857,21 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if if (has_regrid_keyword) then call ESMF_ConfigGetAttribute ( cfg, regrid_method, default="REGRID_METHOD_BILINEAR", & - label=trim(string) // 'regrid_method:' ,rc=status ) - _VERIFY(STATUS) - list(n)%regrid_method = get_regrid_method(trim(regrid_method)) + label=trim(string) // 'regrid_method:' ,_RC ) + list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if ! Get an optional file containing a 1-D track for the output call ESMF_ConfigGetAttribute(cfg, value=list(n)%trackFile, default="", & - label=trim(string) // 'track_file:', rc=status) + label=trim(string) // 'track_file:', _RC) if (trim(list(n)%trackfile) /= '') list(n)%timeseries_output = .true. call ESMF_ConfigGetAttribute(cfg, value=list(n)%recycle_track, default=.false., & - label=trim(string) // 'recycle_track:', rc=status) + label=trim(string) // 'recycle_track:', _RC) ! Handle "backwards" mode: this is hidden (i.e. not documented) feature ! Defaults to .false. call ESMF_ConfigGetAttribute ( cfg, reverse, default=0, & - label=trim(string) // 'backwards:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'backwards:' ,_RC ) list(n)%backwards = (reverse /= 0) ! Disable streams when frequencies, times are negative @@ -959,8 +885,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) old_fields_style = .true. ! unless if (intstate%version >= 2) then call ESMF_ConfigGetAttribute ( cfg, value=field_set_name, label=trim(string)//'field_set:', & - & default='', rc=status) - _VERIFY(status) + & default='', _RC) if (field_set_name /= '') then ! field names already parsed old_fields_style = .false. field_set => intstate%field_sets%at(trim(field_set_name)) @@ -979,10 +904,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Decide on orientation of output ! ------------------------------- - call ESMF_ConfigFindLabel(cfg,trim(string)//'positive:',isPresent=isPresent,rc=status) + call ESMF_ConfigFindLabel(cfg,trim(string)//'positive:',isPresent=isPresent,_RC) if (isPresent) then - call ESMF_ConfigGetAttribute(cfg,value=list(n)%positive,rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(cfg,value=list(n)%positive,_RC) _ASSERT(list(n)%positive=='down'.or.list(n)%positive=='up',"positive value for collection must be down or up") else list(n)%positive = 'down' @@ -996,12 +920,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) len = ESMF_ConfigGetLen( cfg, label=trim(trim(string) // 'levels:'), rc = status ) LEVS: if( status == ESMF_SUCCESS ) then - call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'levels:'), rc = status ) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'levels:'),_RC) j = 0 do i = 1, len - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) cycle j = j + 1 @@ -1023,8 +945,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) INQUIRE ( FILE=trim(tmpstring), EXIST=fileExists ) _ASSERT(fileExists,'needs informative message') - unit = GETFILE(trim(tmpstring), form='formatted', rc=status) - _VERIFY(STATUS) + unit = GETFILE(trim(tmpstring), form='formatted', _RC) if (MAPL_Am_I_Root(vm)) then k=0 @@ -1036,11 +957,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if - call MAPL_CommsBcast(vm, DATA=k, N=1, ROOT=MAPL_Root, RC=status) - _VERIFY(STATUS) + call MAPL_CommsBcast(vm, DATA=k, N=1, ROOT=MAPL_Root, _RC) allocate( list(n)%levels(k), stat = status ) - _VERIFY(STATUS) if (MAPL_Am_I_Root(vm)) then rewind(unit) @@ -1050,8 +969,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if call MAPL_CommsBcast(vm, DATA=list(n)%levels, N=k, & - ROOT=MAPL_Root, RC=status) - _VERIFY(STATUS) + ROOT=MAPL_Root, _RC) call FREE_FILE(UNIT) end if @@ -1060,7 +978,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if(isFileName) cycle allocate( levels(j), stat = status ) - _VERIFY(STATUS) i1 = index(tmpstring(:),",") if( i1.eq.1 ) tmpstring = adjustl( tmpstring(2:) ) j1 = index(tmpstring(:),",")-1 @@ -1068,13 +985,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) read(tmpstring,*) levels(j) if( j.eq.1 ) then allocate( list(n)%levels(j), stat = status ) - _VERIFY(STATUS) list(n)%levels(j) = levels(j) else levels(1:j-1) = list(n)%levels(:) deallocate( list(n)%levels ) allocate( list(n)%levels(j), stat = status ) - _VERIFY(STATUS) list(n)%levels(:) = levels(:) endif deallocate( levels ) @@ -1083,11 +998,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get an interpolating variable ! ----------------------------- - call ESMF_ConfigFindLabel ( cfg,trim(string) // 'vvars:',isPresent=isPresent,rc=STATUS ) + call ESMF_ConfigFindLabel ( cfg,trim(string) // 'vvars:',isPresent=isPresent,_RC ) VINTRP: if(isPresent) then - call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(1), rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(1), _RC) i = index(list(n)%vvars(1)( 1:),"'") j = index(list(n)%vvars(1)(i+1:),"'")+i if( i.ne.0 ) then @@ -1096,11 +1010,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%vvars(1) = adjustl( list(n)%vvars(1) ) endif - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(2),rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(2),_RC) else list(n)%vvars(2) = tmpstring endif @@ -1132,7 +1044,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( .not.found ) then list(n)%field_set%nfields = list(n)%field_set%nfields + 1 - allocate( fields(4, list(n)%field_set%nfields), stat=status ) + allocate( fields(4, list(n)%field_set%nfields), _STAT ) fields(1,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(1,:) fields(2,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(2,:) fields(3,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(3,:) @@ -1141,8 +1053,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) fields(2, list(n)%field_set%nfields ) = list(n)%vvars (2) fields(3, list(n)%field_set%nfields ) = Vvar fields(4, list(n)%field_set%nfields ) = BLANK - deallocate( list(n)%field_set%fields, stat=status ) - _VERIFY(STATUS) + deallocate( list(n)%field_set%fields, _STAT ) list(n)%field_set%fields => fields endif end if @@ -1158,8 +1069,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) select case (intstate%version) case(1:) call ESMF_ConfigGetAttribute ( cfg, tmpString, default='' , & - label=trim(string) // 'grid_label:' ,rc=status ) - _VERIFY(status) + label=trim(string) // 'grid_label:' ,_RC ) if (len_trim(tmpString) == 0) then list(n)%output_grid_label='' else @@ -1180,8 +1090,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) cubeFormat = 0 j = 0 do i = 1,2 - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) cycle j = j + 1 _ASSERT(j<=2,'needs informative message') @@ -1191,8 +1100,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( j1.gt.0 ) tmpstring = adjustl( tmpstring(1:j1) ) read(tmpstring,*) resolution(j) enddo - call list(n)%AddGrid(IntState%output_grids,resolution,rc=status) - _VERIFY(status) + call list(n)%AddGrid(IntState%output_grids,resolution,_RC) else list(n)%output_grid_label='' end if @@ -1204,36 +1112,30 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) newFormat = cubeFormat if (cubeFormat /= 0) then call ESMF_ConfigGetAttribute ( cfg, newFormat, default=cubeFormat, & - label=trim(string) // 'cubeFormat:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'cubeFormat:' ,_RC ) end if list(n)%useNewFormat = (newFormat /= 0) ! Force history so that time averaged collections are timestamped with write time call ESMF_ConfigGetAttribute(cfg, list(n)%ForceOffsetZero, default=.false., & - label=trim(string)//'timestampEnd:', rc=status) - _VERIFY(status) + label=trim(string)//'timestampEnd:', _RC) ! Force history so that time averaged collections are timestamped at the begining of the accumulation interval call ESMF_ConfigGetAttribute(cfg, list(n)%timeStampStart, default=.false., & - label=trim(string)//'timestampStart:', rc=status) - _VERIFY(status) + label=trim(string)//'timestampStart:', _RC) ! Get an optional chunk size ! -------------------------- len = ESMF_ConfigGetLen(cfg, label=trim(trim(string) // 'chunksize:'), rc = status) if ( status == ESMF_SUCCESS ) then - call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'chunksize:'), rc =status) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'chunksize:'), _RC) chnksz = 4 if (list(n)%useNewFormat) then chnksz = 5 end if allocate( list(n)%chunksize(chnksz), stat = status) - _VERIFY(STATUS) j=0 do i=1,len - call ESMF_ConfigGetAttribute( cfg,value=tmpstring, rc=status) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute( cfg,value=tmpstring, _RC) if (trim(tmpstring) == ',' ) cycle j = j + 1 _ASSERT(j<=6,'needs informative message') @@ -1248,17 +1150,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get an optional tile file for regridding the output ! --------------------------------------------------- call ESMF_ConfigGetAttribute ( cfg, value=tilefile, default="", & - label=trim(string) // 'regrid_exch:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'regrid_exch:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=gridname, default="", & - label=trim(string) // 'regrid_name:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'regrid_name:' ,_RC ) NULLIFY(IntState%Regrid(n)%PTR) if (tilefile /= '' .OR. gridname /= '') then - allocate(IntState%Regrid(n)%PTR, stat=status) - _VERIFY(STATUS) + allocate(IntState%Regrid(n)%PTR, _STAT) IntState%Regrid(n)%PTR%tilefile = tilefile IntState%Regrid(n)%PTR%gridname = gridname end if @@ -1302,7 +1201,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = startOfThisMonth else sec = MAPL_nsecf( list(n)%frequency ) - call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, _RC ) RingTime = RefTime end if @@ -1316,16 +1215,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = RingTime + (INT((currTime - RingTime)/frequency)+1)*frequency endif if ( list(n)%backwards ) then - list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if( list(n)%duration.ne.0 ) then if (.not.list(n)%monthly) then sec = MAPL_nsecf( list(n)%duration ) - call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, _RC ) else Frequency = oneMonth !ALT keep the values from above @@ -1337,21 +1235,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = RingTime + (INT((currTime - RingTime)/frequency)+1)*frequency endif if ( list(n)%backwards ) then - list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if (list(n)%monthly .and. (currTime == RingTime)) then - call ESMF_AlarmRingerOn( list(n)%his_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOn( list(n)%his_alarm,_RC ) end if else ! this alarm should never ring, but it is checked if ringing list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, enabled=.false., & - ringTime=currTime, name='historyNewSegment', rc=status ) - _VERIFY(STATUS) + ringTime=currTime, name='historyNewSegment', _RC ) endif ! Mon Alarm based on 1st of Month 00Z @@ -1370,17 +1265,16 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) M = REF_TIME(5), & S = REF_TIME(6), calendar=cal, rc=rc ) - call ESMF_TimeIntervalSet( Frequency, MM=1, calendar=cal, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, MM=1, calendar=cal, _RC ) RingTime = RefTime do while ( RingTime < currTime ) RingTime = RingTime + Frequency enddo if ( list(n)%backwards ) then - list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if(list(n)%monthly) then !ALT this is temporary workaround. It has a memory leak ! we need to at least destroy his_alarm before assignment @@ -1408,24 +1302,20 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) S = REF_TIME(6), calendar=cal, rc=rc ) if ( list(n)%backwards ) then - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, _RC ) else - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) else if ( list(n)%backwards ) then - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, _RC ) else - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, sticky=.false., rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) - call ESMF_AlarmRingerOff(list(n)%end_alarm, rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff(list(n)%end_alarm, _RC ) endif - call ESMF_ConfigDestroy(cfg, rc=status) - _VERIFY(STATUS) + call ESMF_ConfigDestroy(cfg, _RC) enddo LISTLOOP if( MAPL_AM_I_ROOT() ) print * @@ -1433,8 +1323,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! START OF PARSER STUFF size0 = 1 !size( export ) nstatelist = 0 - allocate( statelist(size0), stat=status ) - _VERIFY(STATUS) + allocate( statelist(size0), _STAT ) statelist(1) = '' @@ -1452,13 +1341,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if enddo if(k.eq.nstatelist+1) then - allocate( tmplist (nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( tmplist (nstatelist), _STAT ) tmplist = statelist nstatelist = k deallocate( statelist ) - allocate( statelist(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( statelist(nstatelist), _STAT ) if (k > 1) statelist(1:k-1) = tmplist statelist(k) = list(n)%field_set%fields(2,m) deallocate( tmplist ) @@ -1475,14 +1362,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Output Export States ! ------------------------ - allocate ( exptmp(size0), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp(size0), _STAT ) exptmp(1) = import - allocate ( export(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( export(nstatelist), _STAT ) errorFound = .false. - allocate ( stateListAvail(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( stateListAvail(nstatelist), _STAT ) stateListAvail = .true. if (disableSubVmChecks) then !ALT: setting disableSubVmChecks to .true. automatically assumes that subVm = .false. @@ -1495,10 +1379,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) enddo else do n=1,nstatelist - call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),rc=status ) + call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),_RC ) call ESMF_VMAllReduce(vm, sendData=status, recvData=globalStatus, & reduceflag=ESMF_REDUCE_MAX, rc=localStatus) - _VERIFY(localStatus) if( STATUS/= ESMF_SUCCESS ) then stateListAvail(n) = .false. @@ -1518,8 +1401,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! ---------------------------------------------- list(:)%subVm = .false. do n=1,nlist - allocate( list(n)%expSTATE(list(n)%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( list(n)%expSTATE(list(n)%field_set%nfields), _STAT ) do m=1,list(n)%field_set%nfields ! when we allow regex; some syntax resembles math expressions if (list(n)%regex .or. & @@ -1540,13 +1422,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Important: the next modifies the field's list ! first we check if any regex expressions need to expanded !--------------------------------------------------------- - call wildCardExpand(rc=status) - _VERIFY(status) + call wildCardExpand(_RC) do n=1,nlist m=list(n)%field_set%nfields - allocate(list(n)%r4(m), list(n)%r8(m), list(n)%r8_to_r4(m), stat=status) - _VERIFY(STATUS) + allocate(list(n)%r4(m), list(n)%r8(m), list(n)%r8_to_r4(m), _STAT) end do PARSER: do n=1,nlist @@ -1564,18 +1444,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) endif enddo - allocate(list(n)%tmpfields(list(n)%field_set%nfields), stat=status) - _VERIFY(STATUS) - allocate(list(n)%ReWrite(list(n)%field_set%nfields), stat=status) - _VERIFY(STATUS) + allocate(list(n)%tmpfields(list(n)%field_set%nfields), _STAT) + allocate(list(n)%ReWrite(list(n)%field_set%nfields), _STAT) list(n)%tmpfields='' list(n)%ReWrite= .FALSE. call MAPL_SetExpression(list(n)%field_set%nfields,list(n)%field_set%fields,list(n)%tmpfields,list(n)%rewrite, & list(n)%nPExtraFields, & - list(n)%PExtraFields, list(n)%PExtraGridComp, import,rc=STATUS) - _VERIFY(STATUS) + list(n)%PExtraFields, list(n)%PExtraGridComp, import,_RC) ENDDO PARSER @@ -1594,8 +1471,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) size0 = 1 !size( export ) nstatelist = 0 - allocate( statelist(size0), stat=status ) - _VERIFY(STATUS) + allocate( statelist(size0), _STAT ) statelist(1) = '' @@ -1611,13 +1487,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if enddo if(k.eq.nstatelist+1) then - allocate( tmplist (nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( tmplist (nstatelist), _STAT ) tmplist = statelist nstatelist = k deallocate( statelist ) - allocate( statelist(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( statelist(nstatelist), _STAT ) if (k > 1) statelist(1:k-1) = tmplist statelist(k) = list(n)%field_set%fields(2,m) deallocate( tmplist ) @@ -1628,15 +1502,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Output Export States ! ------------------------ - allocate ( exptmp (size0), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (size0), _STAT ) exptmp(1) = import ! deallocate ( export ) - allocate ( export(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( export(nstatelist), _STAT ) errorFound = .false. - allocate ( stateListAvail(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( stateListAvail(nstatelist), _STAT ) stateListAvail = .true. if (disableSubVmChecks) then !ALT: setting disableSubVmChecks to .true. automatically assumes that subVm = .false. @@ -1649,10 +1520,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) enddo else do n=1,nstatelist - call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),rc=status ) + call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),_RC ) call ESMF_VMAllReduce(vm, sendData=status, recvData=globalStatus, & reduceflag=ESMF_REDUCE_MAX, rc=localStatus) - _VERIFY(localStatus) if( STATUS/= ESMF_SUCCESS ) then stateListAvail(n) = .false. @@ -1683,8 +1553,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! ---------------------------------------------- list(:)%subVm = .false. do n=1,nlist - allocate( list(n)%expSTATE(list(n)%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( list(n)%expSTATE(list(n)%field_set%nfields), _STAT ) do m=1,list(n)%field_set%nfields do k=1,nstatelist if( trim(list(n)%field_set%fields(2,m)) .eq. trim(statelist(k)) ) then @@ -1714,8 +1583,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) errorFound = .true. else if (index(list(n)%field_set%fields(1,m),'%') ==0) then - call MAPL_AllocateCoupling(Field, rc=status) - _VERIFY(STATUS) + call MAPL_AllocateCoupling(Field, _RC) end if end IF @@ -1725,8 +1593,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _ASSERT(.not. errorFound,'needs informative message') - allocate(INTSTATE%AVERAGE (nlist), stat=status) - _VERIFY(STATUS) + allocate(INTSTATE%AVERAGE (nlist), _STAT) IntState%average = .false. do n=1, nlist @@ -1739,14 +1606,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else sec = MAPL_nsecf(list(n)%acc_interval) / 2 endif - call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, rc=status ) - _VERIFY(STATUS) + call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, _RC ) end do nactual = npes if (.not. disableSubVmChecks) then - allocate(allPes(npes), stat=status) - _VERIFY(STATUS) + allocate(allPes(npes), _STAT) minactual = npes do n=1, nlist NULLIFY(list(n)%peAve) @@ -1754,12 +1619,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) localPe(1) = mype if (list(n)%subVm) localPe(1) = -1 call ESMF_VMAllGather(vm, sendData=localPe, recvData=allPEs, & - count=1, rc=status) - _VERIFY(STATUS) + count=1, _RC) nactual = count(allPEs >= 0) minactual = min(minactual, nactual) - allocate(list(n)%peAve(nactual), stat=status) - _VERIFY(STATUS) + allocate(list(n)%peAve(nactual), _STAT) list(n)%peAve = pack(allPEs, allPEs>=0) end do @@ -1767,26 +1630,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) deallocate(allPEs) end if - allocate(INTSTATE%CCS(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%GIM(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%CIM(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%SRCS(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%DSTS(nlist), stat=status) - _VERIFY(STATUS) -! allocate(INTSTATE%GEX(nlist), stat=status) -! _VERIFY(STATUS) -! allocate(INTSTATE%GCNameList(nlist), stat=status) -! _VERIFY(STATUS) + allocate(INTSTATE%CCS(nlist), _STAT) + allocate(INTSTATE%GIM(nlist), _STAT) + allocate(INTSTATE%CIM(nlist), _STAT) + allocate(INTSTATE%SRCS(nlist), _STAT) + allocate(INTSTATE%DSTS(nlist), _STAT) +! allocate(INTSTATE%GEX(nlist), _STAT) +! allocate(INTSTATE%GCNameList(nlist), _STAT) ! Initialize Logical for Grads Control File ! ----------------------------------------- - allocate( INTSTATE%LCTL(nlist), stat=status ) - _VERIFY(STATUS) + allocate( INTSTATE%LCTL(nlist), _STAT ) do n=1,nlist if (list(n)%disabled) cycle if( list(n)%format == 'flat' ) then @@ -1802,8 +1657,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) IntState%GIM(n) = ESMF_StateCreate ( name=trim(list(n)%filename), & stateIntent = ESMF_STATEINTENT_IMPORT, & - rc=status ) - _VERIFY(STATUS) + _RC ) select case (list(n)%mode) case ("instantaneous") @@ -1823,20 +1677,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! query a field from export (arbitrary first field in the stream) for grid_in _ASSERT(size(export(list(n)%expSTATE)) > 0,'needs informative message') call MAPL_StateGet( export(list(n)%expSTATE(1)), & - trim(list(n)%field_set%fields(1,1)), field, rc=status ) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(1,1)), field, _RC ) IntState%Regrid(n)%PTR%state_out = ESMF_StateCreate ( name=trim(list(n)%filename)//'regrid_in', & stateIntent = ESMF_STATEINTENT_IMPORT, & - rc=status ) - _VERIFY(STATUS) + _RC ) ! get grid name, layout, dims - call ESMF_FieldGet(field, grid=grid_in, rc=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, rc=status) - _VERIFY(STATUS) - call ESMF_DistGridGet(distgrid, delayout=layout, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=grid_in, _RC) + call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, _RC) + call ESMF_DistGridGet(distgrid, delayout=layout, _RC) IntState%Regrid(n)%PTR%noxform = .false. @@ -1857,16 +1706,13 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! set the pointer to LocStream call ESMF_AttributeGet(grid_in, name='TILEGRID_LOCSTREAM_ADDR', & - value=ADDR, rc=status) - _VERIFY(STATUS) + value=ADDR, _RC) call c_MAPL_LocStreamRestorePtr(exch, ADDR) ! Get the attached grid - call MAPL_LocStreamGet(EXCH, ATTACHEDGRID=GRID_ATTACHED, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamGet(EXCH, ATTACHEDGRID=GRID_ATTACHED, _RC) - call ESMF_GridGet(grid_attached, name=attachedName, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid_attached, name=attachedName, _RC) if (attachedName == IntState%Regrid(n)%PTR%gridname) then ! T2G @@ -1889,10 +1735,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _ASSERT(associated(LSADDR_PTR),'needs informative message') do i = 1, size(LSADDR_PTR) call c_MAPL_LocStreamRestorePtr(locStream, LSADDR_PTR(i)) - call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(grid, name=tmpstr, rc=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, _RC) + call ESMF_GridGet(grid, name=tmpstr, _RC) if (tmpstr == IntState%Regrid(n)%PTR%gridname) then found = .true. exit @@ -1916,8 +1760,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) !>>> ! get gridnames from exch - call MAPL_LocStreamGet(exch, GRIDNAMES = GNAMES, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamGet(exch, GRIDNAMES = GNAMES, _RC) ngrids = size(gnames) _ASSERT(ngrids==2,'needs informative message') @@ -1937,10 +1780,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) found = .false. do i = 1, size(LSADDR_PTR) call c_MAPL_LocStreamRestorePtr(locStream, LSADDR_PTR(i)) - call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(grid, name=tmpstr, rc=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, _RC) + call ESMF_GridGet(grid, name=tmpstr, _RC) if (tmpstr == gnames(NG)) then found = .true. exit @@ -1956,19 +1797,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) LocStreamIn=exch, & NAME='historyXFORMnative', & UseFCollect=.true., & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) ! get the name and layout of attached grid - call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, rc=status) - _VERIFY(STATUS) - call ESMF_DistGridGet(distgrid, delayout=layout, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, _RC) + call ESMF_DistGridGet(distgrid, delayout=layout, _RC) call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locIn, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, RC=STATUS) - _VERIFY(STATUS) + NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, _RC) end if end if @@ -1982,8 +1819,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locIn, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, RC=STATUS) - _VERIFY(STATUS) + NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, _RC) end if @@ -1992,8 +1828,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (.not. ontiles) then ! get gridnames from loc_in call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locIn, & - GRIDNAMES = GNAMES, RC=STATUS) - _VERIFY(STATUS) + GRIDNAMES = GNAMES, _RC) ! query loc_in for ngrids ngrids = size(gnames) _ASSERT(ngrids==2,'needs informative message') @@ -2026,21 +1861,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) grid_out=pgrid call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locOut, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_out', MASK=(/MAPL_Ocean/), Grid=grid_out, RC=STATUS) - _VERIFY(STATUS) + NAME='history_out', MASK=(/MAPL_Ocean/), Grid=grid_out, _RC) endif ! query ntiles call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locOut, & - NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_out, rc=status) - _VERIFY(STATUS) + NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_out, _RC) if (.not.INTSTATE%Regrid(n)%PTR%noxform) then ! query ntiles call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locIn, & - NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_in, rc=status) - _VERIFY(STATUS) + NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_in, _RC) ! create XFORM call MAPL_LocStreamCreateXform ( XFORM=INTSTATE%Regrid(n)%PTR%XFORM, & @@ -2048,8 +1880,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) LocStreamIn=INTSTATE%Regrid(n)%PTR%LocIn, & NAME='historyXFORM', & UseFCollect=.true., & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) end if endif @@ -2057,25 +1888,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Handle possible extra fields needed for the parser if (list(n)%nPExtraFields > 0) then - allocate ( exptmp (1), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (1), _STAT ) exptmp(1) = import do m=1,list(n)%nPExtraFields - call MAPL_ExportStateGet(exptmp,list(n)%PExtraGridComp(m),parser_state,rc=status) - _VERIFY(STATUS) - call MAPL_StateGet(parser_state,list(n)%PExtraFields(m),parser_field,rc=status) - _VERIFY(STATUS) - call MAPL_AllocateCoupling(parser_field, rc=status) - _VERIFY(STATUS) - f = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,list(n)%PExtraGridComp(m),parser_state,_RC) + call MAPL_StateGet(parser_state,list(n)%PExtraFields(m),parser_field,_RC) + call MAPL_AllocateCoupling(parser_field, _RC) + f = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), _RC) if (IntState%average(n)) then - call MAPL_StateAdd(IntState%CIM(N), f, rc=status) - _VERIFY(STATUS) + call MAPL_StateAdd(IntState%CIM(N), f, _RC) else - call MAPL_StateAdd(IntState%GIM(N), f, rc=status) - _VERIFY(STATUS) + call MAPL_StateAdd(IntState%GIM(N), f, _RC) end if end do @@ -2108,7 +1932,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if ! check if split is needed if (.not. split) then - allocate(splitFields(1), __STAT__) + allocate(splitFields(1), _STAT) splitFields(1) = field else call MAPL_FieldSplit(field, splitFields, aliasName=alias_name, _RC) @@ -2119,7 +1943,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) szr = size(list(n)%r4) if (big > szr) then ! grow - allocate(tmp_r4(big), tmp_r8(big), tmp_r8_to_r4(big), __STAT__) + allocate(tmp_r4(big), tmp_r8(big), tmp_r8_to_r4(big), _STAT) tmp_r4(1:szr) = list(n)%r4 tmp_r8(1:szr) = list(n)%r8 tmp_r8_to_r4(1:szr) = list(n)%r8_to_r4 @@ -2182,7 +2006,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - allocate(gridToFieldMap(gridRank), __STAT__) + allocate(gridToFieldMap(gridRank), _STAT) call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, _RC) notGridded = count(gridToFieldMap==0) @@ -2202,7 +2026,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) allocate(ungriddedLBound(unGridDims), & ungriddedUBound(unGridDims), & ungrd(unGridDims), & - __STAT__) + _STAT) call ESMF_FieldGet(field, Array=array, _RC) @@ -2220,7 +2044,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (isPresent) then call ESMF_AttributeGet(field,name="UNGRIDDED_COORDS",itemcount=ungrdsize,_RC) if ( ungrdsize /= 0 ) then - allocate(ungridded_coord(ungrdsize),__STAT__) + allocate(ungridded_coord(ungrdsize),_STAT) call ESMF_AttributeGet(field,NAME="UNGRIDDED_COORDS",valuelist=ungridded_coord,_RC) end if else @@ -2363,39 +2187,33 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call MAPL_StateCreateFromSpec(IntState%GIM(n), & IntState%DSTS(n)%SPEC, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) ! create CC if (nactual == npes) then IntState%CCS(n) = ESMF_CplCompCreate ( & NAME = list(n)%collection, & contextFlag = ESMF_CONTEXT_PARENT_VM, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) else IntState%CCS(n) = ESMF_CplCompCreate ( & NAME = list(n)%collection, & petList = list(n)%peAve, & contextFlag = ESMF_CONTEXT_OWN_VM, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) end if ! CCSetServ call ESMF_CplCompSetServices (IntState%CCS(n), & - GenericCplSetServices, RC=STATUS ) - _VERIFY(STATUS) + GenericCplSetServices, _RC ) call MAPL_CplCompSetVarSpecs(IntState%CCS(n), & INTSTATE%SRCS(n)%SPEC,& - INTSTATE%DSTS(n)%SPEC,RC=STATUS) - _VERIFY(STATUS) + INTSTATE%DSTS(n)%SPEC,_RC) if (list(n)%monthly) then call MAPL_CplCompSetAlarm(IntState%CCS(n), & - list(n)%his_alarm, RC=STATUS) - _VERIFY(STATUS) + list(n)%his_alarm, _RC) end if ! CCInitialize @@ -2414,12 +2232,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) exportState=INTSTATE%GIM(n), & clock=CLOCK, & userRC=STATUS) + _VERIFY(STATUS) if (status == ESMF_RC_FILE_READ) then list(n)%partial = .true. STATUS = ESMF_SUCCESS call WRITE_PARALLEL("DEBUG: no cpl restart found, producing partial month") end if - _VERIFY(STATUS) end if end if end if @@ -2439,19 +2257,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) !ALT do this all the time if (list(n)%format == 'CFIO') then write(string,'(a,i3.0)') 'STREAM',n - list(n)%bundle = ESMF_FieldBundleCreate(NAME=string, RC=STATUS) - _VERIFY(STATUS) + list(n)%bundle = ESMF_FieldBundleCreate(NAME=string, _RC) if(associated(list(n)%levels)) then LM = size(list(n)%levels) else call ESMF_StateGet(INTSTATE%GIM(n), & - trim(list(n)%field_set%fields(3,1)), field, rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet(field, grid=grid, rc=status ) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(3,1)), field, _RC ) + call ESMF_FieldGet(field, grid=grid, _RC ) + call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, _RC) LM = counts(3) endif @@ -2465,28 +2279,20 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) do m=1,list(n)%field_set%nfields call ESMF_StateGet( state_out, & - trim(list(n)%field_set%fields(3,m)), field, rc=status ) - _VERIFY(STATUS) - - call MAPL_FieldBundleAdd( list(n)%bundle, field, rc=status ) - _VERIFY(STATUS) - - call ESMF_FieldGet(field, Array=array, grid=bgrid, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array, rank=rank, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(3,m)), field, _RC ) + + call MAPL_FieldBundleAdd( list(n)%bundle, field, _RC ) + + call ESMF_FieldGet(field, Array=array, grid=bgrid, _RC) + call ESMF_ArrayGet(array, rank=rank, _RC) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias - call ESMF_GridGet(bgrid, distgrid=bdistgrid, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(bgrid, distgrid=bdistgrid, _RC) !ALT: we need the rank of the distributed grid ! MAPL (and GEOS-5) grid are distributed along X-Y ! tilegrids are distributed only along "tile" dimension - call ESMF_DistGridGet(bdistgrid, dimCount=distRank, rc=status) - _VERIFY(STATUS) - call ESMF_LocalArrayGet(larray, totalCount=counts, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(bdistgrid, dimCount=distRank, _RC) + call ESMF_LocalArrayGet(larray, totalCount=counts, _RC) if(list(n)%field_set%fields(3,m)/=vvarn(n)) then nslices = 1 @@ -2522,29 +2328,19 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%format == 'CFIO') then call Get_Tdim (list(n), clock, tm) if (associated(list(n)%levels) .and. list(n)%vvars(1) /= "") then - list(n)%vdata = VerticalData(levels=list(n)%levels,vcoord=list(n)%vvars(1),vscale=list(n)%vscale,vunit=list(n)%vunit,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(levels=list(n)%levels,vcoord=list(n)%vvars(1),vscale=list(n)%vscale,vunit=list(n)%vunit,_RC) else if (associated(list(n)%levels) .and. list(n)%vvars(1) == "") then - list(n)%vdata = VerticalData(levels=list(n)%levels,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(levels=list(n)%levels,_RC) else - list(n)%vdata = VerticalData(positive=list(n)%positive,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(positive=list(n)%positive,_RC) end if - call list(n)%mGriddedIO%set_param(deflation=list(n)%deflate,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(quantize_algorithm=list(n)%quantize_algorithm,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(quantize_level=list(n)%quantize_level,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(chunking=list(n)%chunkSize,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(nbits_to_keep=list(n)%nbits_to_keep,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(regrid_method=list(n)%regrid_method,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(itemOrder=intState%fileOrderAlphabetical,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%set_param(deflation=list(n)%deflate,_RC) + call list(n)%mGriddedIO%set_param(quantize_algorithm=list(n)%quantize_algorithm,_RC) + call list(n)%mGriddedIO%set_param(quantize_level=list(n)%quantize_level,_RC) + call list(n)%mGriddedIO%set_param(chunking=list(n)%chunkSize,_RC) + call list(n)%mGriddedIO%set_param(nbits_to_keep=list(n)%nbits_to_keep,_RC) + call list(n)%mGriddedIO%set_param(regrid_method=list(n)%regrid_method,_RC) + call list(n)%mGriddedIO%set_param(itemOrder=intState%fileOrderAlphabetical,_RC) if (list(n)%monthly) then nextMonth = currTime - oneMonth dur = nextMonth - currTime @@ -2554,19 +2350,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then - list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),rc=status) - _VERIFY(status) - call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,rc=status) - _VERIFY(status) + list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),_RC) + call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) if (trim(list(n)%output_grid_label)/='') then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) - call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) else - call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,global_attributes=global_attributes,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) end if collection_id = o_Clients%add_hist_collection(list(n)%mGriddedIO%metadata, mode = create_mode) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) @@ -2628,8 +2420,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) integer :: im_world, jm_world,dims(3) pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) if (associated(pgrid)) then - call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,RC=status) - _VERIFY(status) + call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,_RC) print *, ' Output RSLV: ',dims(1),dims(2) end if end block @@ -2651,7 +2442,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) write (*,'(A)',ADVANCE='NO') ' Fields: ' do m=1,list(n)%field_set%nfields if( trim(list(n)%field_set%fields(3,m)).ne.BLANK ) then - write (*,'(A,X)',ADVANCE='NO') trim(list(n)%field_set%fields(3,m)) + write (*,'(A,1X)',ADVANCE='NO') trim(list(n)%field_set%fields(3,m)) endif enddo ! Now advance the write @@ -2679,8 +2470,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) deallocate(stateListAvail) deallocate( statelist ) - call MAPL_GenericInitialize( gc, import, dumexport, clock, rc=status ) - _VERIFY(status) + call MAPL_GenericInitialize( gc, import, dumexport, clock, _RC ) _RETURN(ESMF_SUCCESS) @@ -2712,11 +2502,10 @@ subroutine wildCardExpand(rc) fld_set => list(n)%field_set nfields = fld_set%nfields - allocate(needSplit(nfields), regexList(nfields), stat=status) - _VERIFY(status) + allocate(needSplit(nfields), regexList(nfields), _STAT) regexList = "" - allocate(newItems, stat=status); _VERIFY(status) + allocate(newItems, _STAT) needSplit = .false. @@ -2725,15 +2514,12 @@ subroutine wildCardExpand(rc) do while(iter /= list(n)%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - expand = hasRegex(fldName=item%xname, rc=status) - _VERIFY(status) + expand = hasRegex(fldName=item%xname, _RC) if (.not.expand) call newItems%push_back(item) else if (item%itemType == ItemTypeVector) then ! Lets' not allow regex expand for vectors - expand = hasRegex(fldName=item%xname, rc=status) - _VERIFY(status) - expand = expand.or.hasRegex(fldName=item%yname, rc=status) - _VERIFY(status) + expand = hasRegex(fldName=item%xname, _RC) + expand = expand.or.hasRegex(fldName=item%yname, _RC) if (.not.expand) call newItems%push_back(item) end if @@ -2745,10 +2531,9 @@ subroutine wildCardExpand(rc) if (nregex /= 0) then nfields = nfields - nregex - allocate(newExpState(nfields), stat=status) - _VERIFY(status) - allocate(newFieldSet, stat=status); _VERIFY(status) - allocate(fields(4,nfields), stat=status); _VERIFY(status) + allocate(newExpState(nfields), _STAT) + allocate(newFieldSet, _STAT) + allocate(fields(4,nfields), _STAT) do k = 1, size(fld_set%fields,1) fields(k,:) = pack(fld_set%fields(k,:), mask=.not.needSplit) end do @@ -2766,20 +2551,17 @@ subroutine wildCardExpand(rc) expState = export(list(n)%expSTATE(k)) call MAPL_WildCardExpand(state=expState, regexStr=regexList(k), & - fieldNames=fieldNames, RC=status) - _VERIFY(STATUS) + fieldNames=fieldNames, _RC) do i=1,size(fieldNames) fldName = fieldNames(i) call appendFieldSet(newFieldSet, fldName, & stateName=stateName, & aliasName=fldName, & - specialName='', rc=status) + specialName='', _RC) - _VERIFY(status) ! append expState - call appendArray(newExpState,idx=list(n)%expState(k),rc=status) - _VERIFY(status) + call appendArray(newExpState,idx=list(n)%expState(k),_RC) item%itemType = ItemTypeScalar item%xname = trim(fldName) @@ -2866,21 +2648,16 @@ subroutine MAPL_WildCardExpand(state, regexStr, fieldNames, rc) integer :: nmatches(2, ESMF_MAXSTR) character(len=ESMF_MAXSTR), allocatable :: tmpFldNames(:) - call ESMF_StateGet(state, itemcount=nitems, rc=status) - _VERIFY(status) + call ESMF_StateGet(state, itemcount=nitems, _RC) - allocate(itemNameList(nitems), itemtypeList(nitems), stat=status) - _VERIFY(status) + allocate(itemNameList(nitems), itemtypeList(nitems), _STAT) call ESMF_StateGet(state,itemNameList=itemNameList,& - itemTypeList=itemTypeList,RC=STATUS) - _VERIFY(STATUS) + itemTypeList=itemTypeList,_RC) call regcomp(regex,trim(regexStr),'xmi',status=status) - _VERIFY(STATUS) if (.not.allocated(fieldNames)) then - allocate(fieldNames(0), stat=status) - _VERIFY(status) + allocate(fieldNames(0), _STAT) end if count = size(fieldNames) @@ -2897,8 +2674,7 @@ subroutine MAPL_WildCardExpand(state, regexStr, fieldNames, rc) count = count + 1 ! logic to grow the list - allocate(tmpFldNames(count), stat=status) - _VERIFY(status) + allocate(tmpFldNames(count), _STAT) tmpFldNames(1:count-1) = fieldNames call move_alloc(tmpFldNames, fieldNames) @@ -2941,10 +2717,9 @@ subroutine splitUngriddedFields(rc) end if fld_set => list(n)%field_set nfields = fld_set%nfields - allocate(needSplit(nfields), fldList(nfields), stat=status) - _VERIFY(status) + allocate(needSplit(nfields), fldList(nfields), _STAT) - allocate(newItems, stat=status); _VERIFY(status) + allocate(newItems, _STAT) needSplit = .false. @@ -2954,17 +2729,14 @@ subroutine splitUngriddedFields(rc) split = .false. item => iter%get() if (item%itemType == ItemTypeScalar) then - split = hasSplitableField(fldName=item%xname, rc=status) - _VERIFY(status) + split = hasSplitableField(fldName=item%xname, _RC) if (.not.split) call newItems%push_back(item) else if (item%itemType == ItemTypeVector) then ! Lets' not allow field split for vectors (at least for now); ! it is easy to implement; just tedious - split = hasSplitableField(fldName=item%xname, rc=status) - _VERIFY(status) - split = split.or.hasSplitableField(fldName=item%yname, rc=status) - _VERIFY(status) + split = hasSplitableField(fldName=item%xname, _RC) + split = split.or.hasSplitableField(fldName=item%yname, _RC) if (.not.split) call newItems%push_back(item) _ASSERT(.not. split, 'split field vectors of not allowed yet') @@ -2980,11 +2752,10 @@ subroutine splitUngriddedFields(rc) if (nsplit /= 0) then nfields = nfields - nsplit - allocate(newExpState(nfields), stat=status) - _VERIFY(status) + allocate(newExpState(nfields), _STAT) - allocate(newFieldSet, stat=status); _VERIFY(status) - allocate(fields(4,nfields), stat=status); _VERIFY(status) + allocate(newFieldSet, _STAT) + allocate(fields(4,nfields), _STAT) do k = 1, size(fld_set%fields,1) ! 4 fields(k,:) = pack(fld_set%fields(k,:), mask=.not.needSplit) end do @@ -3001,27 +2772,23 @@ subroutine splitUngriddedFields(rc) stateName = fld_set%fields(2,k) aliasName = fld_set%fields(3,k) - call MAPL_FieldSplit(fldList(k), splitFields, aliasName=aliasName, RC=status) - _VERIFY(STATUS) + call MAPL_FieldSplit(fldList(k), splitFields, aliasName=aliasName, _RC) expState = export(list(n)%expSTATE(k)) do i=1,size(splitFields) call ESMF_FieldGet(splitFields(i), name=fldName, & - rc=status) - _VERIFY(status) + _RC) alias = fldName call appendFieldSet(newFieldSet, fldName, & stateName=stateName, & aliasName=alias, & - specialName='', rc=status) + specialName='', _RC) - _VERIFY(status) ! append expState - call appendArray(newExpState,idx=list(n)%expState(k),rc=status) - _VERIFY(status) + call appendArray(newExpState,idx=list(n)%expState(k),_RC) item%itemType = ItemTypeScalar item%xname = trim(alias) @@ -3104,16 +2871,13 @@ function hasSplitField(fld, rc) result(okToSplit) okToSplit = .false. fldRank = 0 - call ESMF_FieldGet(fld, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(fld, status=fieldStatus, _RC) if (fieldStatus /= ESMF_FIELDSTATUS_COMPLETE) then - call MAPL_AllocateCoupling(fld, rc=status) - _VERIFY(STATUS) + call MAPL_AllocateCoupling(fld, _RC) end if - call ESMF_FieldGet(fld,dimCount=fldRank,rc=status) - _VERIFY(status) + call ESMF_FieldGet(fld,dimCount=fldRank,_RC) _ASSERT(fldRank < 5, "unsupported rank") @@ -3121,12 +2885,10 @@ function hasSplitField(fld, rc) result(okToSplit) okToSplit = .true. else if (fldRank == 3) then ! split ONLY if X and Y are "gridded" and Z is "ungridded" - call ESMF_AttributeGet(fld, name='DIMS', value=dims, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(fld, name='DIMS', value=dims, _RC) if (dims == MAPL_DimsHorzOnly) then call ESMF_AttributeGet(fld, name='UNGRIDDED_DIMS', & - isPresent=has_ungrd, rc=status) - _VERIFY(STATUS) + isPresent=has_ungrd, _RC) if (has_ungrd) then okToSplit = .true. end if @@ -3154,7 +2916,7 @@ subroutine appendArray(array, idx, rc) k = size(array) n = k + 1 - allocate(tmp(n), stat=status) ; _VERIFY(status) + allocate(tmp(n), _STAT) tmp(1:k) = array tmp(n) = idx @@ -3185,15 +2947,14 @@ subroutine appendFieldSet(fldset, fldName, stateName, aliasName, specialName, rc _ASSERT(mm == 4, 'wrong size for fields') k = size(fldset%fields, 2) nn = k + 1 - allocate(flds(mm,nn), stat=status) ; _VERIFY(status) + allocate(flds(mm,nn), _STAT) flds(:,1:k) = fldset%fields flds(1,nn) = fldName flds(2,nn) = stateName flds(3,nn) = aliasName flds(4,nn) = specialName - deallocate( fldSet%fields, stat=status ) - _VERIFY(STATUS) + deallocate( fldSet%fields, _STAT ) fldset%fields => flds fldSet%nfields = nn @@ -3242,8 +3003,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) else usable_collection_name = "unknown" end if - call ESMF_ConfigFindLabel ( cfg, label=label//':', rc=status) - _VERIFY(status) + call ESMF_ConfigFindLabel ( cfg, label=label//':', _RC) table_end = .false. m = 0 @@ -3262,16 +3022,13 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) print * endif endif - _VERIFY(STATUS) export_name = extract_unquoted_item(export_name) ! Get GC Name ! ------------ - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=component_name,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=component_name,_RC) else component_name = tmpstring endif @@ -3280,9 +3037,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible ALIAS Name ! ----------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) ! MAT We don't check this status if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,rc=STATUS) ! MAT We don't check this status else if( trim(tmpstring) /= ' ' ) then export_alias = tmpstring @@ -3298,9 +3055,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible COUPLER Function ! ----------------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) ! MAT We don't check this status if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,rc=STATUS) ! MAT We don't check this status else if( trim(tmpstring) /= ' ' ) then coupler_function_name = tmpstring @@ -3310,12 +3067,10 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) endif coupler_function_name = extract_unquoted_item(coupler_function_name) ! convert to uppercase - tmpstring = ESMF_UtilStringUpperCase(coupler_function_name,rc=status) - _VERIFY(status) + tmpstring = ESMF_UtilStringUpperCase(coupler_function_name,_RC) ! ------------- - call ESMF_ConfigNextLine ( cfg,tableEnd=table_end,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( cfg,tableEnd=table_end,_RC ) vectorDone=.false. idx = index(export_name,";") @@ -3326,8 +3081,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) item%itemType = ItemTypeVector end if VECTORPAIR: do while(.not.vectorDone) - allocate( fields(4,m), stat=status ) - _VERIFY(STATUS) + allocate( fields(4,m), _STAT ) idx = index(export_name,";") if (idx == 0) then @@ -3357,8 +3111,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) fields(4,m) = coupler_function_name deallocate (field_set%fields) endif - allocate( field_set%fields(4,m), stat=status) - _VERIFY(STATUS) + allocate( field_set%fields(4,m), _STAT) field_set%fields = fields deallocate (fields) if (.not.vectorDone) then @@ -3450,7 +3203,6 @@ subroutine Run ( gc, import, export, clock, rc ) !---------------------------------- call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr ! the collections @@ -3462,14 +3214,12 @@ subroutine Run ( gc, import, export, clock, rc ) ! Retrieve the pointer to the generic state !------------------------------------------ - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Get clocks' direction FWD = .not. ESMF_ClockIsReverse(clock) - allocate(Ignore (nlist), stat=status) - _VERIFY(STATUS) + allocate(Ignore (nlist), _STAT) Ignore = .false. ! decide if clock direction and collections' backwards mode agree @@ -3485,13 +3235,11 @@ subroutine Run ( gc, import, export, clock, rc ) call MAPL_TimerOn(GENSTATE,"-ParserRun") if( (.not.list(n)%disabled .and. IntState%average(n)) ) then call MAPL_RunExpression(IntState%CIM(n),list(n)%field_set%fields,list(n)%tmpfields, & - list(n)%ReWrite,list(n)%field_set%nfields,RC=STATUS) - _VERIFY(STATUS) + list(n)%ReWrite,list(n)%field_set%nfields,_RC) end if if( (.not.list(n)%disabled) .and. (.not.IntState%average(n)) ) then call MAPL_RunExpression(IntState%GIM(n),list(n)%field_set%fields,list(n)%tmpfields, & - list(n)%ReWrite,list(n)%field_set%nfields,RC=STATUS) - _VERIFY(STATUS) + list(n)%ReWrite,list(n)%field_set%nfields,_RC) end if call MAPL_TimerOff(GENSTATE,"-ParserRun") endif @@ -3504,8 +3252,7 @@ subroutine Run ( gc, import, export, clock, rc ) !@ do n=1,nlist !@ do m=1,list(n)%field_set%nfields !@ if (list(n)%r8_to_r4(m)) then -!@ call MAPL_FieldCopy(from=list(n)%r8(m), to=list(n)%r4(m), rc=status) -!@ _VERIFY(status) +!@ call MAPL_FieldCopy(from=list(n)%r8(m), to=list(n)%r4(m), _RC) !@ end if !@ end do !@ end do @@ -3521,8 +3268,7 @@ subroutine Run ( gc, import, export, clock, rc ) do m=1,list(n)%field_set%nfields if (list(n)%r8_to_r4(m)) then call MAPL_FieldCopy(from=list(n)%r8(m), & - to=list(n)%r4(m), rc=status) - _VERIFY(status) + to=list(n)%r4(m), _RC) end if end do @@ -3539,11 +3285,9 @@ subroutine Run ( gc, import, export, clock, rc ) ! Check for History Output ! ------------------------ - allocate(Writing (nlist), stat=status) - _VERIFY(STATUS) - allocate(filename(nlist), stat=status) - _VERIFY(STATUS) - allocate(NewSeg (nlist), __STAT__) + allocate(Writing (nlist), _STAT) + allocate(filename(nlist), _STAT) + allocate(NewSeg (nlist), _STAT) newSeg = .false. ! decide if we are writing based on alarms @@ -3559,20 +3303,17 @@ subroutine Run ( gc, import, export, clock, rc ) endif ! if(Writing(n)) then -! call ESMF_AlarmRingerOff( list(n)%his_alarm,rc=status ) -! _VERIFY(STATUS) +! call ESMF_AlarmRingerOff( list(n)%his_alarm,_RC ) ! end if if (Ignore(n)) then ! "Exersise" the alarms and then do nothing Writing(n) = .false. ! if (ESMF_AlarmIsRinging ( list(n)%his_alarm )) then -! call ESMF_AlarmRingerOff( list(n)%his_alarm,rc=status ) -! _VERIFY(STATUS) +! call ESMF_AlarmRingerOff( list(n)%his_alarm,_RC ) ! end if if (ESMF_AlarmIsRinging ( list(n)%seg_alarm )) then - call ESMF_AlarmRingerOff( list(n)%seg_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff( list(n)%seg_alarm,_RC ) end if end if @@ -3581,8 +3322,7 @@ subroutine Run ( gc, import, export, clock, rc ) do m=1,list(n)%field_set%nfields if (list(n)%r8_to_r4(m)) then call MAPL_FieldCopy(from=list(n)%r8(m), & - to=list(n)%r4(m), rc=status) - _VERIFY(status) + to=list(n)%r4(m), _RC) end if end do end if @@ -3593,8 +3333,7 @@ subroutine Run ( gc, import, export, clock, rc ) NewSeg(n) = ESMF_AlarmIsRinging ( list(n)%seg_alarm ) if( NewSeg(n)) then - call ESMF_AlarmRingerOff( list(n)%seg_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff( list(n)%seg_alarm,_RC ) endif end do @@ -3615,8 +3354,7 @@ subroutine Run ( gc, import, export, clock, rc ) call get_DateStamp ( clock, DateStamp=DateStamp, & OFFSET = INTSTATE%STAMPOFFSET(n), & - rc=status ) - _VERIFY(STATUS) + _RC ) if (trim(INTSTATE%expid) == "") then fntmpl = trim(list(n)%filename) @@ -3633,8 +3371,7 @@ subroutine Run ( gc, import, export, clock, rc ) call fill_grads_template ( filename(n), fntmpl, & experiment_id=trim(INTSTATE%expid), & - nymd=nymd, nhms=nhms, rc=status ) ! here is where we get the actual filename of file we will write - _VERIFY(STATUS) + nymd=nymd, nhms=nhms, _RC ) ! here is where we get the actual filename of file we will write if(list(n)%monthly .and. list(n)%partial) then filename(n)=trim(filename(n)) // '-partial' @@ -3649,8 +3386,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! instead we compute the differece between ! thisMonth and lastMonth and as a new timeInterval - call ESMF_ClockGet(clock,currTime=current_time,rc=status) - _VERIFY(status) + call ESMF_ClockGet(clock,currTime=current_time,_RC) call ESMF_TimeIntervalSet( oneMonth, MM=1, _RC) lastMonth = current_time - oneMonth dur = current_time - lastMonth @@ -3662,10 +3398,8 @@ subroutine Run ( gc, import, export, clock, rc ) if (list(n)%timeseries_output) then if (list(n)%unit.eq.0) then if (mapl_am_i_root()) write(6,*)"Sampling to new file: ",trim(filename(n)) - call list(n)%trajectory%close_file_handle(rc=status) - _VERIFY(status) - call list(n)%trajectory%create_file_handle(filename(n),rc=status) - _VERIFY(status) + call list(n)%trajectory%close_file_handle(_RC) + call list(n)%trajectory%create_file_handle(filename(n),_RC) list(n)%currentFile = filename(n) list(n)%unit = -1 end if @@ -3677,8 +3411,7 @@ subroutine Run ( gc, import, export, clock, rc ) inquire (file=trim(filename(n)),exist=file_exists) _ASSERT(.not.file_exists,trim(filename(n))//" being created for History output already exists") end if - call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,_RC) list(n)%currentFile = filename(n) list(n)%unit = -1 else @@ -3718,7 +3451,7 @@ subroutine Run ( gc, import, export, clock, rc ) IntState%Regrid(n)%PTR%LocNative, & IntState%Regrid(n)%PTR%ntiles_in, & IntState%Regrid(n)%PTR%ntiles_out,& - rc=status) + _RC) else call RegridTransform(IntState%GIM(n), & IntState%Regrid(n)%PTR%xform, & @@ -3727,7 +3460,7 @@ subroutine Run ( gc, import, export, clock, rc ) IntState%Regrid(n)%PTR%LocOut, & IntState%Regrid(n)%PTR%ntiles_in, & IntState%Regrid(n)%PTR%ntiles_out,& - rc=status) + _RC) end if else if (IntState%Regrid(n)%PTR%noxform) then @@ -3735,17 +3468,16 @@ subroutine Run ( gc, import, export, clock, rc ) STATE_OUT=state_out, & LS_OUT=IntState%Regrid(n)%PTR%LocOut, & NTILES_OUT=IntState%Regrid(n)%PTR%ntiles_out, & - rc=status) + _RC) else call RegridTransformT2G(STATE_IN=IntState%GIM(n), & XFORM=IntState%Regrid(n)%PTR%xform, & STATE_OUT=state_out, & LS_OUT=IntState%Regrid(n)%PTR%LocOut, & NTILES_OUT=IntState%Regrid(n)%PTR%ntiles_out, & - rc=status) + _RC) end if end if - _VERIFY(STATUS) else state_out = INTSTATE%GIM(n) end if @@ -3753,8 +3485,7 @@ subroutine Run ( gc, import, export, clock, rc ) if (.not.list(n)%timeseries_output) then IOTYPE: if (list(n)%unit < 0) then ! CFIO - call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,_RC) else @@ -3765,14 +3496,12 @@ subroutine Run ( gc, import, export, clock, rc ) INTSTATE%LCTL(n) = .false. endif - call shavebits(state_out, list(n), rc=status) - _VERIFY(STATUS) + call shavebits(state_out, list(n), _RC) do m=1,list(n)%field_set%nfields call MAPL_VarWrite ( list(n)%unit, STATE=state_out, & NAME=trim(list(n)%field_set%fields(3,m)), & - forceWriteNoRestart=.true., rc=status ) - _VERIFY(STATUS) + forceWriteNoRestart=.true., _RC ) enddo call WRITE_PARALLEL("Wrote GrADS Output for File: "//trim(filename(n))) @@ -3818,10 +3547,8 @@ subroutine Run ( gc, import, export, clock, rc ) WRITELOOP: do n=1,nlist if (list(n)%timeseries_output) then - call ESMF_ClockGet(clock,currTime=current_time,rc=status) - _VERIFY(status) - call list(n)%trajectory%append_file(current_time,rc=status) - _VERIFY(status) + call ESMF_ClockGet(clock,currTime=current_time,_RC) + call list(n)%trajectory%append_file(current_time,_RC) end if if( Writing(n) .and. list(n)%unit < 0) then @@ -3872,13 +3599,11 @@ subroutine Finalize ( gc, import, export, clock, rc ) ! Begin... - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr list => IntState%list nlist = size(list) @@ -3891,8 +3616,7 @@ subroutine Finalize ( gc, import, export, clock, rc ) if (list(n)%disabled) cycle IF (list(n)%format == 'CFIO') then if( MAPL_CFIOIsCreated(list(n)%mcfio) ) then - CALL MAPL_CFIOdestroy (list(n)%mcfio, rc=STATUS) - _VERIFY(STATUS) + CALL MAPL_CFIOdestroy (list(n)%mcfio, _RC) end if ELSE if( list(n)%unit.ne.0 ) call FREE_FILE( list(n)%unit ) @@ -3915,17 +3639,14 @@ subroutine Finalize ( gc, import, export, clock, rc ) #if 0 do n=1,nlist IF (IntState%average(n)) then - call MAPL_StateDestroy(IntState%gim(n), rc=status) - _VERIFY(STATUS) - call MAPL_StateDestroy(IntState%cim(n), rc=status) - _VERIFY(STATUS) + call MAPL_StateDestroy(IntState%gim(n), _RC) + call MAPL_StateDestroy(IntState%cim(n), _RC) end IF enddo #endif - call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC=status ) - _VERIFY(STATUS) + call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, _RC ) _RETURN(ESMF_SUCCESS) @@ -3961,7 +3682,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid integer :: DIMS(3) integer :: IM,JM,LM - character*3 :: months(12) + character(len=3) :: months(12) data months /'JAN','FEB','MAR','APR','MAY','JUN', & 'JUL','AUG','SEP','OCT','NOV','DEC'/ @@ -3985,12 +3706,12 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid 'DTDT' , 'PHYSICS' , & 'DTDT' , 'GWD' / - call ESMF_ClockGet ( clock, currTime=CurrTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StopTime=StopTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StartTime=StartTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, Calendar=cal, rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_ClockGet ( clock, currTime=CurrTime, _RC ) + call ESMF_ClockGet ( clock, StopTime=StopTime, _RC ) + call ESMF_ClockGet ( clock, StartTime=StartTime, _RC ) + call ESMF_ClockGet ( clock, Calendar=cal, _RC ) - call ESMF_TimeGet ( CurrTime, timeString=TimeString, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeGet ( CurrTime, timeString=TimeString, _RC ) read(timestring( 1: 4),'(i4.4)') year read(timestring( 6: 7),'(i2.2)') month @@ -4000,7 +3721,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ti = StopTime-CurrTime freq = MAPL_nsecf( list%frequency ) - call ESMF_TimeIntervalSet( Frequency, S=freq, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=freq, StartTime=StartTime, _RC ) nsteps = ti/Frequency + 1 @@ -4021,13 +3742,10 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ! Get Global Horizontal Dimensions ! -------------------------------- - call ESMF_StateGet ( state,trim(list%field_set%fields(3,1)),field,rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet ( field, grid=grid, rc=status ) - _VERIFY(STATUS) + call ESMF_StateGet ( state,trim(list%field_set%fields(3,1)),field,_RC ) + call ESMF_FieldGet ( field, grid=grid, _RC ) - call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, _RC) ZERO = 0 IM = DIMS(1) @@ -4035,8 +3753,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid LM = DIMS(3) if (LM == 0) LM = 1 ! needed for tilegrids - call ESMF_GridGet(grid, name=gridname, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid, name=gridname, _RC) if (gridname(1:10) == 'tile_grid_') then DLON = 1.0 @@ -4060,15 +3777,13 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid Name = "Latitude" , & Location = ESMF_STAGGERLOC_CENTER , & Units = MAPL_UnitsRadians , & - RC = STATUS ) - _VERIFY(STATUS) + _RC) call ESMFL_GridCoordGet( GRID, LONS , & Name = "Longitude" , & Location = ESMF_STAGGERLOC_CENTER , & Units = MAPL_UnitsRadians , & - RC = STATUS ) - _VERIFY(STATUS) + _RC) !ALT: Note: the LATS(1,1) and LONS(1,1) are correct ONLY on root if( MAPL_AM_I_ROOT() ) then @@ -4090,8 +3805,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid integer :: dims(3) pgrid => output_grids%at(trim(list%output_grid_label)) if (associated(pgrid)) then - call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,RC=status) - _VERIFY(status) + call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,_RC) IM = dims(1) JM = dims(2) DLON = 360._REAL64/float(IM) @@ -4108,18 +3822,14 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ! Compute Vertical Dimension for each Field (Augment nfield for VDIMS > LM) ! ------------------------------------------------------------------------- - allocate( vdim(list%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( vdim(list%field_set%nfields), _STAT ) vdim = 0 nfield = list%field_set%nfields do m = 1,list%field_set%nfields call ESMFL_StateGetFieldArray( state,trim(list%field_set%fields(3,m)),array,status ) - _VERIFY(STATUS) - call ESMF_ArrayGet( array, localarrayList=larrayList, rc=status ) - _VERIFY(STATUS) + call ESMF_ArrayGet( array, localarrayList=larrayList, _RC ) call ESMF_LocalArrayGet( larrayList(1), RANK=rank, totalLBound=lbounds, & - totalUBound=ubounds, rc=status ) - _VERIFY(STATUS) + totalUBound=ubounds, _RC ) if( rank==3 ) then vdim(m) = ubounds(3)-lbounds(3)+1 if( vdim(m).gt.LM ) nfield = nfield+1 @@ -4229,12 +3939,12 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) integer :: YY,MM,DD,H,M,S integer :: noffset - character*4 year - character*2 month - character*2 day - character*2 hour - character*2 minute - character*2 second + character(len=4) :: year + character(len=2) :: month + character(len=2) :: day + character(len=2) :: hour + character(len=2) :: minute + character(len=2) :: second integer :: STATUS @@ -4246,17 +3956,14 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) equivalence ( string(15),minute ) equivalence ( string(18),second ) - call ESMF_ClockGet ( clock, name=clockname, currTime=currentTime, rc=status) - _VERIFY(STATUS) + call ESMF_ClockGet ( clock, name=clockname, currTime=currentTime, _RC) if (present(offset)) then - call ESMF_TimeIntervalGet( OFFSET, S=noffset, rc=status ) - _VERIFY(STATUS) + call ESMF_TimeIntervalGet( OFFSET, S=noffset, _RC ) if( noffset /= 0 ) then LPERP = ( index( trim(clockname),'_PERPETUAL' ).ne.0 ) if( LPERP ) then - call ESMF_ClockGetAlarm ( clock, AlarmName='PERPETUAL', alarm=PERPETUAL, rc=status ) - _VERIFY(STATUS) + call ESMF_ClockGetAlarm ( clock, AlarmName='PERPETUAL', alarm=PERPETUAL, _RC ) if( ESMF_AlarmIsRinging(PERPETUAL) ) then ! ! Month has already been set back to PERPETUAL Month, therefore @@ -4267,14 +3974,14 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) DD = DD, & H = H , & M = M , & - S = S, rc=status ) + S = S, _RC ) MM = MM + 1 call ESMF_TimeSet ( CurrentTime, YY = YY, & MM = MM, & DD = DD, & H = H , & M = M , & - S = S, rc=status ) + S = S, _RC ) #ifdef DEBUG if( MAPL_AM_I_ROOT() ) write(6,"(a,2x,i4.4,'/',i2.2,'/',i2.2,2x,'Time: ',i2.2,':',i2.2,':',i2.2)") "Inside HIST GetDate: ",YY,MM,DD,H,M,S #endif @@ -4284,8 +3991,7 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) currentTime = currentTime - offset end if - call ESMF_TimeGet (currentTime, timeString=TimeString, rc=status) - _VERIFY(STATUS) + call ESMF_TimeGet (currentTime, timeString=TimeString, _RC) if(present(DateStamp)) then DateStamp = year//month//day//'_'//hour//minute//second //'z' @@ -4321,57 +4027,41 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, type (ESMF_StateItem_Flag), pointer :: ITEMTYPES_IN(:), ITEMTYPES_OUT(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) - allocate(tile_in (ntiles_in ), stat=status) - _VERIFY(STATUS) - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tile_in (ntiles_in ), _STAT) + allocate(tile_out(ntiles_out), _STAT) - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) - - call ESMF_ArrayGet(array_in , rank=rank_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) + + call ESMF_ArrayGet(array_in , rank=rank_in , _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_in == rank_out,'needs informative message') _ASSERT(rank_in >=2, 'Rank is less than 2') _ASSERT(rank_in <= 3,'Rank is greater than 3') @@ -4380,15 +4070,11 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, LM = 1 LL = 1 LU = 1 - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) else - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_in,3) LL = lbound(ptr3d_in,3) LU = ubound(ptr3d_in,3) @@ -4403,14 +4089,11 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, ptr2d_out => ptr3d_out(:,:,L) end if - call MAPL_LocStreamTransform(LS_IN, TILE_IN, PTR2d_IN, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_IN, TILE_IN, PTR2d_IN, _RC) - call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, _RC ) - call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, _RC) ENDDO @@ -4467,69 +4150,48 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ type (ESMF_StateItem_Flag), pointer :: ITEMTYPES_IN(:), ITEMTYPES_OUT(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) - allocate(tt_in (ntiles_in ), stat=status) - _VERIFY(STATUS) - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tt_in (ntiles_in ), _STAT) + allocate(tile_out(ntiles_out), _STAT) - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) - call MAPL_LocStreamGet(LS_NTV, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) - allocate(G2d_in(COUNTS(1),COUNTS(2)), stat=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(LS_NTV, ATTACHEDGRID=GRID, _RC) + call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, _RC) + allocate(G2d_in(COUNTS(1),COUNTS(2)), _STAT) - call MAPL_LocStreamGet(LS_ntv, NT_LOCAL = sizett, rc=status) - _VERIFY(STATUS) - allocate(tt(sizett), stat=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(LS_ntv, NT_LOCAL = sizett, _RC) + allocate(tt(sizett), _STAT) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) - call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_in+1 == rank_out,'needs informative message') _ASSERT(rank_in >=1, 'Rank is less than 1') @@ -4538,55 +4200,43 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ KM = 1 if (rank_in == 1) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , _RC) tile_in => ptr1d_in else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p1dr8_in)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p1dr8_in)), _STAT) end if tile1d = p1dr8_in tile_in => tile1d end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) out2d => ptr2d_out LM = 1 else if (rank_in == 2) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p2dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p2dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_out,3) else if (rank_in == 3) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p3dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p3dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, _RC) LM = size(ptr4d_out,3) KM = size(ptr4d_out,4) else @@ -4614,21 +4264,16 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ end if ! T2T - call MAPL_LocStreamTransform( tt, XFORMntv, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tt, XFORMntv, tile_in, _RC ) ! T2G - call MAPL_LocStreamTransform(LS_NTV, G2d_IN, tt, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_NTV, G2d_IN, tt, _RC) ! G2T - call MAPL_LocStreamTransform(LS_IN, TT_IN, G2d_IN, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_IN, TT_IN, G2d_IN, _RC) ! T2T - call MAPL_LocStreamTransform( tile_out, XFORM, tt_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tt_in, _RC ) ! T2G - call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, _RC) ENDDO END DO @@ -4682,109 +4327,82 @@ subroutine RegridTransformT2G(STATE_IN, XFORM, STATE_OUT, LS_OUT, NTILES_OUT, RC character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) if (present(XFORM)) then - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tile_out(ntiles_out), _STAT) end if - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) - - call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) + + call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_out == rank_in + 1,'needs informative message') KM = 1 if (rank_in == 1) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , _RC) tile_in => ptr1d_in else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p1dr8_in)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p1dr8_in)), _STAT) end if tile1d = p1dr8_in tile_in => tile1d end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) out2d => ptr2d_out LM = 1 else if (rank_in == 2) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p2dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p2dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_out,3) else if (rank_in == 3) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p3dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p3dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, _RC) LM = size(ptr4d_out,3) KM = size(ptr4d_out,4) else @@ -4812,14 +4430,12 @@ subroutine RegridTransformT2G(STATE_IN, XFORM, STATE_OUT, LS_OUT, NTILES_OUT, RC end if if (present(XFORM)) then - call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, _RC ) else tile_out => tile_in endif - call MAPL_LocStreamTransform(LS_OUT, OUT2d, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, OUT2d, TILE_OUT, _RC) END DO END DO @@ -4919,12 +4535,12 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ExtraFields,ExtraGridComp,ExpState,rc) integer,intent(in)::nfield - character*(*), intent(inout) :: fields(:,:) - character*(*), intent(inout) :: tmpfields(:) + character(len=*), intent(inout) :: fields(:,:) + character(len=*), intent(inout) :: tmpfields(:) logical, intent(inout) :: rewrite(:) integer, intent(inout) :: nPExtraFields - character*(*), pointer, intent(inout) :: ExtraFields(:) - character*(*), pointer, intent(inout) :: ExtraGridComp(:) + character(len=*), pointer, intent(inout) :: ExtraFields(:) + character(len=*), pointer, intent(inout) :: ExtraGridComp(:) type(ESMF_State), intent(inout) :: ExpState integer, optional, intent(out ) :: rc @@ -4961,8 +4577,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ! rather than the actual output field variables (i.e., fields(1,:)). ! Also do check that there are no illegal operations !------------------------------------------------------------------- - allocate ( exptmp (1), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (1), _STAT ) exptmp(1) = ExpState ! check which fields are actual exports or expressions nPExtraFields = 0 @@ -4970,8 +4585,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & allocate(isBundle(nfield)) do m=1,nfield - call MAPL_ExportStateGet(exptmp,fields(2,m),state,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,fields(2,m),state,_RC) if (index(fields(1,m),'%') == 0) then call checkIfStateHasField(state, fields(1,m), hasField, _RC) if (hasField) then @@ -4993,10 +4607,8 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & enddo ! now that we know this allocated a place to store the names of the real fields - allocate(VarNames(iRealFields),stat=status) - _VERIFY(STATUS) - allocate(VarNeeded(iRealFields),stat=status) - _VERIFY(STATUS) + allocate(VarNames(iRealFields),_STAT) + allocate(VarNeeded(iRealFields),_STAT) k=0 do m=1,nfield if ( (rewrite(m) .eqv. .False.) .and. (isBundle(m) .eqv. .False.) ) then @@ -5013,8 +4625,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & if (rewrite(m)) then ExtVars = "" - call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,_RC) tmpList=ExtVars do i=1,len_trim(tmpList) @@ -5039,8 +4650,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & if (rewrite(m)) then ExtVars = "" - call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,_RC) tmpList=ExtVars do i=1,len_trim(tmpList) @@ -5079,16 +4689,11 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & end do totFields = iRealFields + nUniqueExtraFields - allocate(TotVarNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotCmpNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotAliasNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotRank(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotLoc(totFields),stat=status) - _VERIFY(STATUS) + allocate(TotVarNames(totFields),_STAT) + allocate(TotCmpNames(totFields),_STAT) + allocate(TotAliasNames(totFields),_STAT) + allocate(TotRank(totFields),_STAT) + allocate(TotLoc(totFields),_STAT) iRealFields = 0 do i=1,nfield @@ -5098,15 +4703,11 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & TotCmpNames(iRealFields) = trim(fields(2,i)) TotAliasNames(iRealFields) = trim(fields(3,i)) - call MAPL_ExportStateGet(exptmp,fields(2,i),state,rc=status) - _VERIFY(STATUS) - call MAPL_StateGet(state,fields(1,i),field,rc=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(field,name='DIMS',value=dims,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,fields(2,i),state,_RC) + call MAPL_StateGet(state,fields(1,i),field,_RC) + call ESMF_AttributeGet(field,name='DIMS',value=dims,_RC) TotRank(iRealFields) = dims - call ESMF_AttributeGet(field,name='VLOCATION',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='VLOCATION',value=dims,_RC) TotLoc(iRealFields) = dims endif @@ -5118,24 +4719,18 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & TotVarNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,1) TotCmpNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,2) TotAliasNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,1) - call MAPL_ExportStateGet ( exptmp,NonUniqueVarNames(i,2),state,rc=status ) - _VERIFY(STATUS) - call MAPL_StateGet(state, NonUniqueVarNames(i,1),field,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet ( exptmp,NonUniqueVarNames(i,2),state,_RC ) + call MAPL_StateGet(state, NonUniqueVarNames(i,1),field,_RC) - call ESMF_AttributeGet(field,name='DIMS',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='DIMS',value=dims,_RC) TotRank(iRealFields+nUniqueExtraFields) = dims - call ESMF_AttributeGet(field,name='VLOCATION',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='VLOCATION',value=dims,_RC) TotLoc(iRealFields+nUniqueExtraFields) = dims end if end do - allocate(extraFields(nUniqueExtraFields),stat=status) - _VERIFY(STATUS) - allocate(extraGridComp(nUniqueExtraFields),stat=status) - _VERIFY(STATUS) + allocate(extraFields(nUniqueExtraFields),_STAT) + allocate(extraGridComp(nUniqueExtraFields),_STAT) nPExtraFields = nUniqueExtraFields nUniqueExtraFields = 0 do i=1,nExtraFields @@ -5155,15 +4750,13 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ! But the actual arithmetic parsing field already has been copied to the temporialy field. ! Also we will do some syntax checking here since this is a good place !---------------------------------------------------------------------- - allocate(VarNeeded(TotFields),stat=status) - _VERIFY(STATUS) + allocate(VarNeeded(TotFields),_STAT) do m=1,nfield if (Rewrite(m) .eqv. .TRUE.) then largest_rank =0 ifound_vloc=.false. - call CheckSyntax(tmpfields(m),TotAliasNames,VarNeeded,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),TotAliasNames,VarNeeded,_RC) do i=1,TotFields if (VarNeeded(i)) then if (TotRank(i)> largest_rank) then @@ -5204,7 +4797,7 @@ end subroutine MAPL_SetExpression subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) type (ESMF_State), intent(in) :: state - character*(*), intent(in):: fields(:,:),tmpfields(:) + character(len=*), intent(in):: fields(:,:),tmpfields(:) logical, intent(inout) :: rewrite(:) integer, intent(in):: nfield integer, optional, intent(out) :: rc @@ -5217,11 +4810,9 @@ subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) do m=1,nfield if (rewrite(m)) then fname = trim(fields(3,m)) - call MAPL_StateGet(state,fname,field,rc=status) - _VERIFY(STATUS) + call MAPL_StateGet(state,fname,field,_RC) fexpr = tmpfields(m) - call MAPL_StateEval(state,fexpr,field,rc=status) - _VERIFY(STATUS) + call MAPL_StateEval(state,fexpr,field,_RC) end if enddo @@ -5244,47 +4835,33 @@ subroutine MAPL_StateDestroy(State, RC) integer :: I, J, N, NF - call ESMF_StateGet(state, ITEMCOUNT=N, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state, ITEMCOUNT=N, _RC) - allocate(itemNameList(N), STAT=STATUS) - _VERIFY(STATUS) - allocate(itemtypeList(N), STAT=STATUS) - _VERIFY(STATUS) + allocate(itemNameList(N), _STAT) + allocate(itemtypeList(N), _STAT) - call ESMF_StateGet(state,ITEMNAMELIST=itemNamelist,ITEMTYPELIST=itemtypeList,RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state,ITEMNAMELIST=itemNamelist,ITEMTYPELIST=itemtypeList,_RC) do I=1,N if(itemtypeList(I)==ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,itemNameList(I),FIELD,RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldDestroy(FIELD, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemNameList(I),FIELD,_RC) + call ESMF_FieldDestroy(FIELD, _RC) else if(itemtypeList(I)==ESMF_STATEITEM_FieldBundle) then - call ESMF_StateGet(state,itemNameList(I), BUNDLE, RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldBundleGet(BUNDLE,FieldCount=NF, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemNameList(I), BUNDLE, _RC) + call ESMF_FieldBundleGet(BUNDLE,FieldCount=NF, _RC) DO J=1,NF - call ESMF_FieldBundleGet(BUNDLE, J, FIELD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldDestroy(field, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, J, FIELD, _RC) + call ESMF_FieldDestroy(field, _RC) END DO - call ESMF_FieldBundleDestroy(BUNDLE, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleDestroy(BUNDLE, _RC) else if(itemtypeList(I)==ESMF_STATEITEM_State) then !ALT we ingore nested states for now, they will get destroyed by their GC end if end do - call ESMF_StateDestroy(STATE, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateDestroy(STATE, _RC) - deallocate(itemNameList, STAT=STATUS) - _VERIFY(STATUS) - deallocate(itemtypeList, STAT=STATUS) - _VERIFY(STATUS) + deallocate(itemNameList, _STAT) + deallocate(itemtypeList, _STAT) _RETURN(ESMF_SUCCESS) end subroutine MAPL_StateDestroy @@ -5313,7 +4890,6 @@ subroutine MAPL_StateGet(state,name,field,rc) else call ESMF_StateGet(state,trim(name),field,rc=status) _ASSERT(status==ESMF_SUCCESS,'Field '//trim(name)//' not found') - _VERIFY(STATUS) end if _RETURN(ESMF_SUCCESS) @@ -5350,20 +4926,17 @@ subroutine RecordRestart( gc, import, export, clock, rc ) ! Check if it is time to do anything doRecord = .false. - call MAPL_InternalStateRetrieve(GC, meta, rc=status) - _VERIFY(status) + call MAPL_InternalStateRetrieve(GC, meta, _RC) - doRecord = MAPL_RecordAlarmIsRinging(meta, rc=status) + doRecord = MAPL_RecordAlarmIsRinging(meta, _RC) if (.not. doRecord) then _RETURN(ESMF_SUCCESS) end if - call MAPL_DateStampGet(clock, datestamp, rc=status) - _VERIFY(STATUS) + call MAPL_DateStampGet(clock, datestamp, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr list => IntState%list nlist = size(list) @@ -5377,12 +4950,10 @@ subroutine RecordRestart( gc, import, export, clock, rc ) if (.not. list(n)%partial) then ! save the compname - call ESMF_CplCompGet (INTSTATE%CCS(n), name=fname_saved, rc=status) - _VERIFY(status) + call ESMF_CplCompGet (INTSTATE%CCS(n), name=fname_saved, _RC) ! add timestamp to filename filename = trim(fname_saved) // datestamp - call ESMF_CplCompSet (INTSTATE%CCS(n), name=filename, rc=status) - _VERIFY(status) + call ESMF_CplCompSet (INTSTATE%CCS(n), name=filename, _RC) call ESMF_CplCompWriteRestart (INTSTATE%CCS(n), & importState=INTSTATE%CIM(n), & @@ -5391,8 +4962,7 @@ subroutine RecordRestart( gc, import, export, clock, rc ) userRC=STATUS) _VERIFY(STATUS) ! restore the compname - call ESMF_CplCompSet (INTSTATE%CCS(n), name=fname_saved, rc=status) - _VERIFY(status) + call ESMF_CplCompSet (INTSTATE%CCS(n), name=fname_saved, _RC) end if end if end if @@ -5410,15 +4980,11 @@ subroutine checkIfStateHasField(state, fieldName, hasField, rc) character (len=ESMF_MAXSTR), allocatable :: itemNameList(:) type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - call ESMF_StateGet(state, itemcount=n, rc=status) - _VERIFY(status) + call ESMF_StateGet(state, itemcount=n, _RC) - allocate(itemNameList(n), stat=status) - _VERIFY(status) - allocate(itemTypeList(n), stat=status) - _VERIFY(status) - call ESMF_StateGet(state,itemnamelist=itemNamelist,itemtypelist=itemTypeList,rc=status) - _VERIFY(STATUS) + allocate(itemNameList(n), _STAT) + allocate(itemTypeList(n), _STAT) + call ESMF_StateGet(state,itemnamelist=itemNamelist,itemtypelist=itemTypeList,_RC) hasField = .false. do I=1,N @@ -5428,10 +4994,8 @@ subroutine checkIfStateHasField(state, fieldName, hasField, rc) exit end if end do - deallocate(itemNameList, stat=status) - _VERIFY(STATUS) - deallocate(itemTypeList, stat=status) - _VERIFY(status) + deallocate(itemNameList, _STAT) + deallocate(itemTypeList, _STAT) _RETURN(ESMF_SUCCESS) end subroutine checkIfStateHasField @@ -5444,30 +5008,28 @@ subroutine shavebits( state, list, rc) integer :: m, fieldRank, status type(ESMF_Field) :: field real, pointer :: ptr1d(:), ptr2d(:,:), ptr3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm if (list%nbits_to_keep >=MAPL_NBITS_UPPER_LIMIT) then _RETURN(ESMF_SUCCESS) endif + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) + do m=1,list%field_set%nfields - call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet(field, rank=fieldRank,rc=status) + call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,_RC ) + call ESMF_FieldGet(field, rank=fieldRank,_RC) if (fieldRank ==1) then - call ESMF_FieldGet(field, farrayptr=ptr1d, rc=status) - _VERIFY(STATUS) - call pFIO_DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr1d, _RC) + call DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) elseif (fieldRank ==2) then - call ESMF_FieldGet(field, farrayptr=ptr2d, rc=status) - _VERIFY(STATUS) - call pFIO_DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr2d, _RC) + call DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) elseif (fieldRank ==3) then - call ESMF_FieldGet(field, farrayptr=ptr3d, rc=status) - _VERIFY(STATUS) - call pFIO_DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr3d, _RC) + call DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) else _FAIL('The field rank is not implmented') endif @@ -5492,8 +5054,8 @@ subroutine CopyStateItems(src, dst, rc) call ESMF_StateGet(src, itemCount=itemCount, _RC) - allocate(itemnames(itemcount), __STAT__) - allocate(itemtypes(itemcount), __STAT__) + allocate(itemnames(itemcount), _STAT) + allocate(itemtypes(itemcount), _STAT) call ESMF_StateGet(src, itemNameList=itemNames, & itemTypeList=itemTypes, _RC) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 94e0d1c3d3a..dd63f711a17 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -74,36 +74,27 @@ function HistoryTrajectory_from_file(filename,unusable,rc) result(trajectory) type(FileMetadataUtils) :: metadata type(FileMetadata) :: basic_metadata integer :: num_times - + _UNUSED_DUMMY(unusable) - call formatter%open(trim(filename),pFIO_READ,rc=status) - _VERIFY(status) - basic_metadata = formatter%read(rc=status) - _VERIFY(status) + call formatter%open(trim(filename),pFIO_READ,_RC) + basic_metadata = formatter%read(_RC) call metadata%create(basic_metadata,trim(filename)) - num_times = metadata%get_dimension("time",rc=status) - _VERIFY(status) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),stat=status) - _VERIFY(status) + num_times = metadata%get_dimension("time",_RC) + allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) if (metadata%is_var_present("longitude")) then - call formatter%get_var("longitude",trajectory%lons,rc=status) - _VERIFY(status) + call formatter%get_var("longitude",trajectory%lons,_RC) end if if (metadata%is_var_present("latitude")) then - call formatter%get_var("latitude",trajectory%lats,rc=status) - _VERIFY(status) + call formatter%get_var("latitude",trajectory%lats,_RC) end if - - call metadata%get_time_info(timeVector=trajectory%times,rc=status) - _VERIFY(status) - trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,rc=status) - _VERIFY(status) - trajectory%root_locstream = trajectory%locstream_factory%create_locstream(rc=status) - _VERIFY(status) - - _RETURN(_SUCCESS) - + + call metadata%get_time_info(timeVector=trajectory%times,_RC) + trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,_RC) + trajectory%root_locstream = trajectory%locstream_factory%create_locstream(_RC) + + _RETURN(_SUCCESS) + end function HistoryTrajectory_from_file subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc) @@ -131,17 +122,13 @@ subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc if (present(vdata)) then this%vdata=vdata else - this%vdata=VerticalData(rc=status) - _VERIFY(status) + this%vdata=VerticalData(_RC) end if - call this%vdata%append_vertical_metadata(this%metadata,this%bundle,rc=status) - _VERIFY(status) + call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,rc=status) - _VERIFY(status) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) - call timeInfo%add_time_to_metadata(this%metadata,rc=status) - _VERIFY(status) + call timeInfo%add_time_to_metadata(this%metadata,_RC) this%time_info = timeInfo nobs = size(this%times) v = variable(type=PFIO_REAL64,dimensions="time") @@ -158,46 +145,37 @@ subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call this%create_variable(item%xname,rc=status) - _VERIFY(status) + call this%create_variable(item%xname,_RC) else if (item%itemType == ItemTypeVector) then - call this%create_variable(item%xname,rc=status) - _VERIFY(status) - call this%create_variable(item%yname,rc=status) - _VERIFY(status) + call this%create_variable(item%xname,_RC) + call this%create_variable(item%yname,_RC) end if call iter%next() enddo - - call ESMF_FieldBundleGet(this%bundle,grid=grid,rc=status) - !this%dist_locstream = this%locstream_factory%create_locstream(grid=grid,rc=status) - !_VERIFY(status) + + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + !this%dist_locstream = this%locstream_factory%create_locstream(grid=grid,_RC) this%number_written = 0 this%previous_index = lbound(this%times,1)-1 - call timeInfo%get(clock=clock,rc=status) - _VERIFY(status) - call ESMF_ClockGet(clock,currTime=this%previous_time,rc=status) - _VERIFY(status) - - this%regridder = LocStreamRegridder(grid,this%root_locstream,rc=status) - _VERIFY(status) - call this%create_output_bundle(rc=status) - _VERIFY(status) + call timeInfo%get(clock=clock,_RC) + call ESMF_ClockGet(clock,currTime=this%previous_time,_RC) + + this%regridder = LocStreamRegridder(grid,this%root_locstream,_RC) + call this%create_output_bundle(_RC) this%file_name = '' - + this%recycle_track=.false. if (present(recycle_track)) then this%recycle_track=recycle_track end if if (this%recycle_track) then - call this%reset_times_to_current_day(rc=status) - _VERIFY(status) + call this%reset_times_to_current_day(_RC) end if _RETURN(_SUCCESS) end subroutine initialize - + function compute_times_for_interval(this,interval,rc) result(rtimes) class(HistoryTrajectory), intent(inout) :: this integer, intent(in) :: interval(2) @@ -212,35 +190,30 @@ function compute_times_for_interval(this,interval,rc) result(rtimes) if (all(interval==0)) then _RETURN(_SUCCESS) end if - call this%get_file_start_time(file_start_time,tunits,rc=status) - _VERIFY(status) - allocate(rtimes(ntimes),stat=status) - _VERIFY(status) + call this%get_file_start_time(file_start_time,tunits,_RC) + allocate(rtimes(ntimes),_STAT) icnt=0 do i=interval(1),interval(2) icnt=icnt+1 tint = this%times(i)-file_start_time select case(trim(tunits)) case ('days') - call ESMF_TimeIntervalGet(tint,d_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,d_r8=rtimes(icnt),_RC) case ('hours') - call ESMF_TimeIntervalGet(tint,h_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,h_r8=rtimes(icnt),_RC) case ('minutes') - call ESMF_TimeIntervalGet(tint,m_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,m_r8=rtimes(icnt),_RC) end select enddo _RETURN(_SUCCESS) - end function compute_times_for_interval + end function compute_times_for_interval function get_current_interval(this,current_time,rc) result(interval) class(HistoryTrajectory), intent(inout) :: this type(ESMF_Time), intent(inout) :: current_time integer, optional, intent(out) :: rc integer :: interval(2) - integer :: i,nfound + integer :: i,nfound logical :: found found = .false. @@ -248,7 +221,7 @@ function get_current_interval(this,current_time,rc) result(interval) interval = 0 do i=this%previous_index+1,size(this%times) if (this%times(i) .ge. this%previous_time .and. this%times(i) .le. current_time) then - if (.not.found) then + if (.not.found) then interval(1) = i found = .true. end if @@ -275,23 +248,17 @@ subroutine create_variable(this,vname,rc) type(variable) :: v logical :: is_present - call ESMF_FieldBundleGet(this%bundle,vname,field=field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(field,name=var_name,rank=field_rank,rc=status) - _VERIFY(status) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,vname,field=field,_RC) + call ESMF_FieldGet(field,name=var_name,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, _RC) else long_name = var_name endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,rc=status) - _VERIFY(status) + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, _RC) else units = 'unknown' endif @@ -306,11 +273,10 @@ subroutine create_variable(this,vname,rc) call v%add_attribute('missing_value',MAPL_UNDEF) call v%add_attribute('_FillValue',MAPL_UNDEF) call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) - call this%metadata%add_variable(trim(var_name),v,rc=status) - _VERIFY(status) + call this%metadata%add_variable(trim(var_name),v,_RC) end subroutine create_variable - + subroutine create_output_bundle(this,rc) class(HistoryTrajectory), intent(inout) :: this integer, optional, intent(out) :: rc @@ -321,41 +287,33 @@ subroutine create_output_bundle(this,rc) type(ESMF_Field) :: src_field,dst_field integer :: rank,lb(1),ub(1) - this%output_bundle = ESMF_FieldBundleCreate(rc=status) - _VERIFY(status) + this%output_bundle = ESMF_FieldBundleCreate(_RC) iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(src_field,rank=rank,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) if (rank==2) then dst_field = ESMF_FieldCreate(this%root_locstream,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,rc=status) - _VERIFY(status) + typekind=ESMF_TYPEKIND_R4,_RC) else if (rank==3) then - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) if (this%vdata%lm/=(ub(1)-lb(1)+1)) then lb(1)=1 ub(1)=this%vdata%lm end if dst_field = ESMF_FieldCreate(this%root_locstream,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,rc=status) - _VERIFY(status) + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) end if - call MAPL_FieldBundleAdd(this%output_bundle,dst_field,rc=status) - _VERIFY(status) + call MAPL_FieldBundleAdd(this%output_bundle,dst_field,_RC) else if (item%itemType == ItemTypeVector) then - _VERIFY(status) - _VERIFY(status) + _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo - + end subroutine create_output_bundle subroutine create_file_handle(this,filename,rc) @@ -367,15 +325,11 @@ subroutine create_file_handle(this,filename,rc) integer :: status this%file_name = trim(filename) - v = this%time_info%define_time_variable(rc=status) - _VERIFY(status) - call this%metadata%modify_variable('time',v,rc=status) - _VERIFY(status) + v = this%time_info%define_time_variable(_RC) + call this%metadata%modify_variable('time',v,_RC) if (mapl_am_I_root()) then - call this%file_handle%create(trim(filename),rc=status) - _VERIFY(status) - call this%file_handle%write(this%metadata,rc=status) - _VERIFY(status) + call this%file_handle%create(trim(filename),_RC) + call this%file_handle%write(this%metadata,_RC) end if this%number_written = 0 @@ -388,8 +342,7 @@ subroutine close_file_handle(this,rc) if (trim(this%file_name) /= '') then if (mapl_am_i_root()) then - call this%file_handle%close(rc=status) - _VERIFY(status) + call this%file_handle%close(_RC) end if end if @@ -417,83 +370,63 @@ subroutine append_file(this,current_time,rc) number_to_write = 0 else number_to_write = interval(2)-interval(1)+1 - end if + end if if (number_to_write>0) then - rtimes = this%compute_times_for_interval(interval,rc=status) - _VERIFY(status) + rtimes = this%compute_times_for_interval(interval,_RC) if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(rc=status) - _VERIFY(status) + call this%vdata%setup_eta_to_pressure(_RC) end if if (mapl_am_i_root()) then call this%file_handle%put_var('time',rtimes,& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) call this%file_handle%put_var('longitude',this%lons(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) call this%file_handle%put_var('latitude',this%lats(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) end if deallocate(rtimes) iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(src_field,rank=rank,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,rc=status) - _VERIFY(status) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,rc=status) - _VERIFY(status) - call this%regridder%regrid(p_src_2d,p_dst_2d,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) if (mapl_am_i_root()) then call this%file_handle%put_var(trim(item%xname),p_dst_2d(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write]) + start=[this%number_written+1],count=[number_to_write]) end if else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,rc=status) - _VERIFY(status) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),stat=status) - _VERIFY(status) - call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,rc=status) - call this%regridder%regrid(p_new_lev,p_dst_3d,rc=status) - _VERIFY(status) + allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),_STAT) + call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,_RC) + call this%regridder%regrid(p_new_lev,p_dst_3d,_RC) else - call this%regridder%regrid(p_src_3d,p_dst_3d,rc=status) - _VERIFY(status) + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) end if if (mapl_am_i_root()) then call this%file_handle%put_var(trim(item%xname),p_dst_3d(interval(1):interval(2),:),& - start=[this%number_written+1,1],count=[number_to_write,size(p_dst_3d,2)]) + start=[this%number_written+1,1],count=[number_to_write,size(p_dst_3d,2)]) end if end if else if (item%itemType == ItemTypeVector) then - _VERIFY(status) - _VERIFY(status) + _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo this%number_written=this%number_written+number_to_write endif - call ESMF_TimeGet(this%previous_time,dd=previous_day,rc=status) - _VERIFY(status) - call ESMF_TimeGet(current_time,dd=current_day,rc=status) - _VERIFY(status) + call ESMF_TimeGet(this%previous_time,dd=previous_day,_RC) + call ESMF_TimeGet(current_time,dd=current_day,_RC) if (this%recycle_track .and. (current_day/=previous_day)) then - call this%reset_times_to_current_day(rc=status) - _VERIFY(status) + call this%reset_times_to_current_day(_RC) this%previous_index = lbound(this%times,1)-1 end if this%previous_time=current_time @@ -519,8 +452,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) integer lastspace,since_pos integer year,month,day,hour,min,sec - var => this%metadata%get_variable('time',rc=status) - _VERIFY(status) + var => this%metadata%get_variable('time',_RC) attr => var%get_attribute('units') ptimeUnits => attr%get_value() select type(pTimeUnits) @@ -598,8 +530,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) class default _FAIL("Time unit must be character") end select - call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,rc=status) - _VERIFY(status) + call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) _RETURN(_SUCCESS) end subroutine get_file_start_time @@ -622,16 +553,12 @@ subroutine reset_times_to_current_day(this,rc) type(ESMF_Time) :: current_time integer :: year,month,day - call this%time_info%get(clock=clock,rc=status) - _VERIFY(status) - call ESMF_ClockGet(clock,currtime=current_time,rc=status) - _VERIFY(status) - call ESMF_TimeGet(current_time,yy=year,mm=month,dd=day,rc=status) - _VERIFY(status) + call this%time_info%get(clock=clock,_RC) + call ESMF_ClockGet(clock,currtime=current_time,_RC) + call ESMF_TimeGet(current_time,yy=year,mm=month,dd=day,_RC) do i=1,size(this%times) - call ESMF_TimeGet(this%times(i),yy=yp,mm=mp,dd=dp,h=h,m=m,s=s,ms=ms,us=us,ns=ns,rc=status) - _VERIFY(status) - call ESMF_TimeSet(this%times(i),yy=year,mm=month,dd=day,h=h,m=m,s=s,ms=ms,us=us,ns=ns,rc=status) + call ESMF_TimeGet(this%times(i),yy=yp,mm=mp,dd=dp,h=h,m=m,s=s,ms=ms,us=us,ns=ns,_RC) + call ESMF_TimeSet(this%times(i),yy=year,mm=month,dd=day,h=h,m=m,s=s,ms=ms,us=us,ns=ns,_RC) enddo end subroutine reset_times_to_current_day diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 351fcbda73d..cea3383893f 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -22,6 +22,7 @@ module MAPL_GriddedIOMod use gFTL_StringVector use gFTL_StringStringMap use MAPL_FileMetadataUtilsMod + use MAPL_DownbitMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL64 use ieee_arithmetic, only: isnan => ieee_is_nan @@ -142,6 +143,13 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr end if this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) _VERIFY(status) + + ! We get the regrid_method here because in the case of Identity, we set it to + ! REGRID_METHOD_IDENTITY in the regridder constructor if identity. Now we need + ! to change the regrid_method in the GriddedIO object to be the same as the + ! the regridder object. + this%regrid_method = this%regrid_handle%get_regrid_method() + call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) _VERIFY(status) factory => get_factory(this%output_grid,rc=status) @@ -366,7 +374,7 @@ subroutine CreateVariable(this,itemName,rc) call v%add_attribute('add_offset',0.0) call v%add_attribute('_FillValue',MAPL_UNDEF) call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) - call v%add_attribute('regrid_method', translate_regrid_method(this%regrid_method)) + call v%add_attribute('regrid_method', regrid_method_int_to_string(this%regrid_method)) call factory%append_variable_metadata(v) call this%metadata%add_variable(trim(varName),v,rc=status) _VERIFY(status) @@ -865,6 +873,12 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) integer, allocatable :: localStart(:),globalStart(:),globalCount(:) integer, allocatable :: gridLocalStart(:),gridGlobalStart(:),gridGlobalCount(:) class (AbstractGridFactory), pointer :: factory + real, allocatable :: temp_2d(:,:), temp_3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) factory => get_factory(this%output_grid,rc=status) _VERIFY(status) @@ -881,7 +895,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(Field,farrayPtr=ptr2d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_2d,source=ptr2d) + call DownBit(temp_2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else @@ -896,7 +911,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_3d,source=ptr3d) + call DownBit(temp_3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 1557e979e0b..840662c1252 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -10,8 +10,6 @@ endif() set (srcs # pFIO Files - pFIO_ShaveMantissa.c - DownBit.F90 pFIO_Constants.F90 UnlimitedEntity.F90 Attribute.F90 @@ -132,7 +130,8 @@ endforeach() ecbuild_add_executable ( TARGET pfio_open_close.x SOURCES pfio_open_close.F90 - LIBS ${this} ) + LIBS ${this}) + set_target_properties (pfio_open_close.x PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) ecbuild_add_executable ( diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index 55819444dbf..a6a94a4dbcf 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -56,7 +56,9 @@ subroutine serialize(this, buffer, rc) else buffer = buff_tmp endif - + if ( size(buffer, kind=8) > huge(0)) then + _FAIL("need to increase oserver's number of front cores (nfront)") + endif _RETURN(_SUCCESS) end subroutine serialize diff --git a/pfio/MessageVector.F90 b/pfio/MessageVector.F90 index 4777b8eeacb..3935eaffe53 100644 --- a/pfio/MessageVector.F90 +++ b/pfio/MessageVector.F90 @@ -27,9 +27,10 @@ module pFIO_MessageVectorUtilMod contains - subroutine serialize_message_vector(msgVec,buffer) + subroutine serialize_message_vector(msgVec,buffer, rc) type (MessageVector),intent(in) :: msgVec integer, allocatable,intent(inout) :: buffer(:) + integer, optional, intent(out) :: rc integer, allocatable :: tmp(:) class (AbstractMessage),pointer :: msg integer :: n, i @@ -42,7 +43,13 @@ subroutine serialize_message_vector(msgVec,buffer) msg=>msgVec%at(i) tmp =[tmp, parser%encode(msg)] enddo + + if(size(tmp, kind=8) > huge(0)) then + _FAIL("need to increase oserver's nfront") + endif + i = size(tmp)+1 + if (allocated(buffer)) deallocate(buffer) buffer =[i,tmp] diff --git a/pfio/MpiSocket.F90 b/pfio/MpiSocket.F90 index 3f1aeaa8918..6f29569021c 100644 --- a/pfio/MpiSocket.F90 +++ b/pfio/MpiSocket.F90 @@ -156,10 +156,13 @@ function put(this, request_id, local_reference, rc) result(handle) integer, pointer :: data(:) integer :: n_words + integer(kind=INT64) :: big_n tag = make_tag(request_id) - n_words = product(local_reference%shape) * word_size(local_reference%type_kind) + big_n = product(int(local_reference%shape, INT64)) * word_size(local_reference%type_kind) + _ASSERT( big_n < huge(0), "Increase the number of processors to decrease the local size of data to be sent") + n_words = big_n call c_f_pointer(local_reference%base_address, data, shape=[n_words]) if (n_words ==0) allocate(data(1)) call MPI_Isend(data, n_words, MPI_INTEGER, this%pair_remote_rank, tag, this%pair_comm, request, ierror) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index ec8ef6ab7b2..9d286513337 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -597,8 +597,8 @@ subroutine start_back_writers(rc) integer, pointer :: g_1d(:), l_1d(:), g_2d(:,:), l_2d(:,:), g_3d(:,:,:), l_3d(:,:,:) integer, pointer :: g_4d(:,:,:,:), l_4d(:,:,:,:), g_5d(:,:,:,:,:), l_5d(:,:,:,:,:) - integer :: msize_word, d_rank, request_id - integer :: s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 + integer :: d_rank, request_id + integer(kind=INT64) :: msize_word, s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 type (StringAttributeMap) :: vars_map type (StringAttributeMapIterator) :: var_iter type (IntegerMessageMap) :: msg_map @@ -607,6 +607,7 @@ subroutine start_back_writers(rc) class (*), pointer :: x_ptr(:) integer , allocatable :: buffer_v(:) type (Attribute), pointer :: attr_ptr + type (Attribute) :: attr_tmp type (c_ptr) :: address type (ForwardDataAndMessage), target :: f_d_m type (FileMetaData) :: fmd @@ -664,11 +665,13 @@ subroutine start_back_writers(rc) type is (CollectiveStageDataMessage) var_iter = vars_map%find(i_to_string(q%request_id)) if (var_iter == vars_map%end()) then - msize_word = word_size(q%type_kind)*product(q%global_count) + msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) allocate(buffer_v(msize_word), source = -1) - call vars_map%insert(i_to_string(q%request_id), Attribute(buffer_v)) - var_iter = vars_map%find(i_to_string(q%request_id)) + attr_tmp = Attribute(buffer_v) deallocate(buffer_v) + call vars_map%insert(i_to_string(q%request_id),attr_tmp) + call attr_tmp%destroy() + var_iter = vars_map%find(i_to_string(q%request_id)) call msg_map%insert(q%request_id, q) endif attr_ptr => var_iter%value() diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index b7442380403..cda0e7f878a 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -39,8 +39,13 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: close procedure :: read procedure :: write + procedure :: add_variable #include "new_overload.macro" + + procedure :: ___SUB(get_var,string,0) + procedure :: ___SUB(get_var,string,1) + procedure :: ___SUB(get_var,int32,0) procedure :: ___SUB(get_var,int32,1) procedure :: ___SUB(get_var,int32,2) @@ -62,6 +67,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(get_var,real64,3) procedure :: ___SUB(get_var,real64,4) + procedure :: ___SUB(put_var,string,0) + procedure :: ___SUB(put_var,string,1) procedure :: ___SUB(put_var,int32,0) procedure :: ___SUB(put_var,int32,1) procedure :: ___SUB(put_var,int32,2) @@ -84,6 +91,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(put_var,real64,4) + generic :: get_var => ___SUB(get_var,string,0) + generic :: get_var => ___SUB(get_var,string,1) generic :: get_var => ___SUB(get_var,int32,0) generic :: get_var => ___SUB(get_var,int32,1) generic :: get_var => ___SUB(get_var,int32,2) @@ -105,6 +114,8 @@ module pFIO_NetCDF4_FileFormatterMod generic :: get_var => ___SUB(get_var,real64,3) generic :: get_var => ___SUB(get_var,real64,4) + generic :: put_var => ___SUB(put_var,string,0) + generic :: put_var => ___SUB(put_var,string,1) generic :: put_var => ___SUB(put_var,int32,0) generic :: put_var => ___SUB(put_var,int32,1) generic :: put_var => ___SUB(put_var,int32,2) @@ -656,12 +667,31 @@ subroutine put_var_attributes(this, var, varid, unusable, rc) end subroutine put_var_attributes + subroutine add_variable(this, cf, varname, unusable, rc) + class (NetCDF4_FileFormatter), intent(inout) :: this + type (FileMetadata), target, intent(in) :: cf + character(*), intent(in) :: varname + class (KeywordEnforcer), optional, intent(in) :: unusable + !integer, optional, intent(in) :: chunksizes(:) + integer, optional, intent(out) :: rc + integer:: status + + status=nf90_redef(this%ncid) + _VERIFY(status) + call this%def_variables(cf, varname=varname, _RC) + status=nf90_enddef(this%ncid) + _VERIFY(status) + _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) + + end subroutine add_variable - subroutine def_variables(this, cf, unusable, rc) + subroutine def_variables(this, cf, unusable, varname, rc) class (NetCDF4_FileFormatter), intent(inout) :: this type (FileMetadata), target, intent(in) :: cf class (KeywordEnforcer), optional, intent(in) :: unusable !integer, optional, intent(in) :: chunksizes(:) + character(*), optional,intent(in) :: varname integer, optional, intent(out) :: rc integer :: status @@ -693,6 +723,12 @@ subroutine def_variables(this, cf, unusable, rc) var_iter = order%begin() do while (var_iter /= order%end()) var_name => var_iter%get() + if ( present (varname)) then + if (var_name /= varname) then + call var_iter%next() + cycle + endif + endif var => vars%at(var_name) xtype = get_xtype(var%get_type(),rc=status) _VERIFY(status) @@ -710,7 +746,6 @@ subroutine def_variables(this, cf, unusable, rc) idim = idim + 1 end do _VERIFY(status) - !$omp critical status = nf90_def_var(this%ncid, var_name, xtype, dimids, varid) !$omp end critical @@ -1279,9 +1314,17 @@ end subroutine inq_variables # undef _RANK #undef _VARTYPE - -#undef _TYPE - + ! string +#define _VARTYPE 0 +# define _RANK 0 +# include "NetCDF4_get_var.H" +# include "NetCDF4_put_var.H" +# undef _RANK +# define _RANK 1 +# include "NetCDF4_get_var.H" +# include "NetCDF4_put_var.H" +# undef _RANK +#undef _VARTYPE ! Kludge to support parallel write with UNLIMITED dimension integer function inq_dim(this, dim_name, unusable, rc) result(length) diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index e09e8a94422..caa471eecf5 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -824,16 +824,16 @@ subroutine put_DataToFile(this, message, address, rc) case (1:) select case (message%type_kind) case (pFIO_INT32) - call c_f_pointer(address, values_int32_1d, [product(count)]) + call c_f_pointer(address, values_int32_1d, [product(int(count, INT64))]) call formatter%put_var(message%var_name, values_int32_1d, start=start, count=count, _RC) case (pFIO_INT64) - call c_f_pointer(address, values_int64_1d, [product(count)]) + call c_f_pointer(address, values_int64_1d, [product(int(count, INT64))]) call formatter%put_var(message%var_name, values_int64_1d, start=start, count=count, _RC) case (pFIO_REAL32) - call c_f_pointer(address, values_real32_1d, [product(count)]) + call c_f_pointer(address, values_real32_1d,[product(int(count, INT64))]) call formatter%put_var(message%var_name, values_real32_1d, start=start, count=count, _RC) case (pFIO_REAL64) - call c_f_pointer(address, values_real64_1d, [product(count)]) + call c_f_pointer(address, values_real64_1d,[product(int(count, INT64))]) call formatter%put_var(message%var_name, values_real64_1d, start=start, count=count, _RC) case default _FAIL( "not supported type") diff --git a/pfio/UnlimitedEntity.F90 b/pfio/UnlimitedEntity.F90 index a8f3c706c27..a5ebc58327f 100644 --- a/pfio/UnlimitedEntity.F90 +++ b/pfio/UnlimitedEntity.F90 @@ -55,6 +55,7 @@ module pFIO_UnlimitedEntityMod procedure :: serialize procedure :: get_string procedure :: is_empty + procedure :: destroy end type UnlimitedEntity ! This derived type is a workaround for sporadic Intel Fortran @@ -253,6 +254,16 @@ subroutine set(this, value, rc) _RETURN(_SUCCESS) end subroutine set + subroutine destroy(this, rc) + class (UnlimitedEntity), intent(inout) :: this + integer, optional, intent(out) :: rc + if(allocated(this%value)) deallocate(this%value) + if(allocated(this%values)) deallocate(this%values) + if(allocated(this%shape)) deallocate(this%shape) + _RETURN(_SUCCESS) + end subroutine destroy + + ! get string or scalar ! get string or scalar function get_value(this, rc) result(value) class (UnlimitedEntity), target, intent(in) :: this diff --git a/pfio/new_overload.macro b/pfio/new_overload.macro index b0419176e0a..169b999fcda 100644 --- a/pfio/new_overload.macro +++ b/pfio/new_overload.macro @@ -53,7 +53,8 @@ #if (_VARTYPE == 0) #define _MPITYPE MPI_BYTE -#define _TYPEKIND character(len=*) +#define _TYPEDECLARE character(len=*) +#define _TYPEKIND string #define _TYPEKINDSTR 'STRING' #elif (_VARTYPE == 1) diff --git a/pfio/pFIO.F90 b/pfio/pFIO.F90 index 9f3c96d15b2..395a60a339b 100644 --- a/pfio/pFIO.F90 +++ b/pfio/pFIO.F90 @@ -28,7 +28,6 @@ module pFIO use pFIO_ArrayReferenceMod use pFIO_StringAttributeMapMod use pFIO_StringVariableMapMod - use pFIO_DownBitMod use pFIO_LocalMemReferenceMod use pFIO_FormatterPtrVectorMod use pFIO_StringVectorUtilMod diff --git a/pfio/tests/Test_NetCDF4_FileFormatter.pf b/pfio/tests/Test_NetCDF4_FileFormatter.pf index 2b2c2af857e..3ad19ac9ddb 100644 --- a/pfio/tests/Test_NetCDF4_FileFormatter.pf +++ b/pfio/tests/Test_NetCDF4_FileFormatter.pf @@ -137,4 +137,44 @@ contains end subroutine test_write_read_variable_attribute + @test + subroutine test_add_variable() + type (NetCDF4_FileFormatter) :: formatter + type (FileMetadata) :: cf_expected + type (FileMetadata) :: cf_found + type (Variable) :: v,v1 + integer :: status + + call cf_expected%add_dimension('x',1) + call cf_expected%add_dimension('y',2) + + v = Variable(type=pFIO_INT32, dimensions='x,y') + call v%add_attribute('attr', [1.,2.,3.]) + call cf_expected%add_variable('var', v) + + call formatter%create('test.nc', rc=status) + @assertEqual(NF90_NOERR, status) + call formatter%write(cf_expected, rc=status) + @assertEqual(0, NF90_NOERR) + call formatter%close(rc=status) + @assertEqual(0, NF90_NOERR) + + call formatter%open('test.nc', mode=NF90_WRITE, rc=status) + @assertEqual(NF90_NOERR, status) + v1 = Variable(type=pFIO_INT32, dimensions='x,y') + call cf_expected%add_variable('new_var', v1) + call formatter%add_variable(cf_expected,'new_var', rc=status) + call formatter%close(rc=status) + @assertEqual(0, NF90_NOERR) + + call formatter%open('test.nc', mode=NF90_NOWRITE, rc=status) + @assertEqual(0, NF90_NOERR) + cf_found = formatter%read(rc=status) + call formatter%close(rc=status) + @assertEqual(0, NF90_NOERR) + + @assertTrue(cf_expected == cf_found) + + end subroutine test_add_variable + end module Test_NetCDF4_FileFormatter diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index dfb33d1d6eb..e61ae7a52b3 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -25,6 +25,8 @@ set (srcs FileSystemUtilities.F90 DSO_Utilities.F90 MAPL_ISO8601_DateTime.F90 + DownBit.F90 + ShaveMantissa.c # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 @@ -39,6 +41,8 @@ endif () target_include_directories (${this} PUBLIC $) +set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) + target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") if (PFUNIT_FOUND) diff --git a/pfio/DownBit.F90 b/shared/DownBit.F90 similarity index 69% rename from pfio/DownBit.F90 rename to shared/DownBit.F90 index 96760f9a852..579e62d7c9e 100644 --- a/pfio/DownBit.F90 +++ b/shared/DownBit.F90 @@ -1,20 +1,23 @@ -module pFIO_DownbitMod +#include "MAPL_Generic.h" +module MAPL_DownbitMod use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc, c_ptr + use mpi + use MAPL_ExceptionHandling implicit none private - public :: pFIO_DownBit + public :: DownBit - interface pFIO_DownBit - module procedure pFIO_DownBit1D - module procedure pFIO_DownBit2D - module procedure pFIO_DownBit3D - end interface pFIO_DownBit + interface DownBit + module procedure DownBit1D + module procedure DownBit2D + module procedure DownBit3D + end interface DownBit contains - subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit3D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -27,6 +30,7 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -55,13 +59,13 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) integer :: k do k = lbound(x,3), ubound(x,3) - call pFIO_DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & - undef=undef, flops=flops, rc=rc ) + call DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & + undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc ) end do - end subroutine pFIO_DownBit3D + end subroutine DownBit3D - subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit2D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -73,6 +77,7 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -114,13 +119,20 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) ! !EOP !------------------------------------------------------------------------------ - integer :: E, xbits, has_undef + integer :: E, xbits, has_undef, passed_minmax real :: scale, xmin, xmax, tol, undef_ logical :: shave_mantissa - integer, external :: pFIO_ShaveMantissa32 + integer, external :: MAPL_ShaveMantissa32 + real :: min_value, max_value + integer :: useable_mpi_comm,status rc = 0 + if (present(mpi_comm)) then + useable_mpi_comm = mpi_comm + else + useable_mpi_comm = MPI_COMM_NULL + end if ! Defaults for optinal arguments ! ------------------------------ if ( present(undef) ) then @@ -143,7 +155,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) xr = x ! compiled r8 this will convert to r4. xbits = 24 - nbits_to_keep - rc = pFIO_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x) ) + call compute_min_max(xr,min_value,max_value,undef_,useable_mpi_comm,_RC) + if (useable_mpi_comm/=MPI_COMM_NULL) passed_minmax = 1 + rc = MAPL_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x), passed_minmax, min_value, max_value ) return ! Slow, flops in FORTRAN (GRIB inspired) @@ -180,9 +194,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) end if - end subroutine pFIO_DownBit2D + end subroutine DownBit2D - subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit1D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE ! ! !INPUT PARAMETERS: @@ -192,6 +206,7 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -208,8 +223,38 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) xr_ptr = c_loc(xr(1)) call c_f_pointer(xr_ptr, xr_tmp,[size(x),1]) - call pFIO_Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, rc=rc) - - end subroutine pFIO_Downbit1D - -end module pFIO_DownbitMod + call Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc) + + end subroutine Downbit1D + + subroutine compute_min_max(array,min_value,max_value,undef_value,mpi_comm,rc) + real, intent(in) :: array(:,:) + real, intent(out) :: min_value + real, intent(out) :: max_value + real, intent(in ) :: undef_value + integer, intent(in ) :: mpi_comm + integer, optional, intent(out) :: rc + + real :: local_min_value, local_max_value + logical, allocatable :: undef_mask(:,:) + integer :: status + + allocate(undef_mask(size(array,1),size(array,2))) + undef_mask = .false. + where(array /= undef_value) undef_mask = .true. + + local_min_value = minval(array,mask=undef_mask) + local_max_value = maxval(array,mask=undef_mask) + if (mpi_comm /= MPI_COMM_NULL) then + call MPI_AllReduce(local_min_value,min_value,1,MPI_FLOAT,MPI_MIN,mpi_comm,status) + _VERIFY(status) + call MPI_AllReduce(local_max_value,max_value,1,MPI_FLOAT,MPI_MAX,mpi_comm,status) + _VERIFY(status) + else + min_value = local_min_value + max_value = local_max_value + end if + _RETURN(_SUCCESS) + end subroutine + +end module MAPL_DownbitMod diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index b48e69f3b0d..404e987803a 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -20,5 +20,6 @@ module MaplShared use mapl_Constants use mapl_CommGroupDescriptionMod use mapl_AbstractCommSplitterMod + use mapl_DownbitMod end module MaplShared diff --git a/pfio/pFIO_ShaveMantissa.c b/shared/ShaveMantissa.c similarity index 79% rename from pfio/pFIO_ShaveMantissa.c rename to shared/ShaveMantissa.c index 145fb9617f1..5d84136d73a 100644 --- a/pfio/pFIO_ShaveMantissa.c +++ b/shared/ShaveMantissa.c @@ -2,7 +2,7 @@ #include #include #include -#include "pFIO_ShaveMantissa.h" /* protype */ +#include "ShaveMantissa.h" /* protype */ #define MAXBITS 20 @@ -22,7 +22,7 @@ //======================================== -float32 pfio_SetOffset(float32 minv, float32 maxv) +float32 MAPL_SetOffset(float32 minv, float32 maxv) { float32 midv, mnabs, range; @@ -43,7 +43,7 @@ float32 pfio_SetOffset(float32 minv, float32 maxv) // // !INTERFACE: */ -int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize ) +int MAPL_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize, int passed_minmax, float32 arr_min, float32 arr_max ) /* // !INPUT PARAMETERS: @@ -101,7 +101,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int // was not copying input to output arrays. // 10Mar2009 Suarez Used a union for the shaving. Also changed the // SKIP checks and protected the max and min. -// 24oct2009 da Silva Changed abs() to fabs() in pfio_SetOffset; moved float32 +// 24oct2009 da Silva Changed abs() to fabs() in MAPL_SetOffset; moved float32 // defs to header so that it can be used with prototype. // 28oct2010 da Silva Changed another occurence of abs() -> fabs() //EOP @@ -125,14 +125,14 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int if ( len < 0 || xbits < 1 ) { fprintf(stderr, - "ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", + "MAPL_ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", len, xbits ); return 1; } if ( xbits > MAXBITS ) { fprintf(stderr, - "ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", + "MAPL_ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", xbits, MAXBITS ); return 2; } @@ -155,7 +155,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int b = a; if(ain!=a) { if(labs(ain-a)