diff --git a/.circleci/config.yml b/.circleci/config.yml new file mode 100644 index 000000000000..db31fe0261c5 --- /dev/null +++ b/.circleci/config.yml @@ -0,0 +1,61 @@ +version: 2.1 + +executors: + gcc-build-env: + docker: + - image: gmao/geos-build-env-gcc-source:6.0.10 + environment: + OMPI_ALLOW_RUN_AS_ROOT: 1 + OMPI_ALLOW_RUN_AS_ROOT_CONFIRM: 1 + OMPI_MCA_btl_vader_single_copy_mechanism: none + +jobs: + build-and-test-GNU: + executor: gcc-build-env + working_directory: /root/project + steps: + - checkout + - run: + name: Versions, etc. + command: mpirun --version && gfortran --version && echo $BASEDIR && pwd && ls + - run: + name: Mepo clone external repos + command: | + mepo init + mepo clone + mepo status + - run: + name: CMake + command: | + mkdir build + cd build + cmake .. -DBASEDIR=$BASEDIR/Linux -DCMAKE_Fortran_COMPILER=gfortran -DCMAKE_BUILD_TYPE=Debug -DMPIEXEC_PREFLAGS='--oversubscribe' + - run: + name: Build and install + command: | + cd build + make -j2 install + - run: + name: Run pFIO Unit tests + command: | + cd build + make -j2 pFIO_tests + ctest -R 'pFIO_tests$' --output-on-failure + - run: + name: Run MAPL_Base Unit tests + command: | + cd build + make -j2 MAPL_Base_tests + ctest -R 'MAPL_Base_tests$' --output-on-failure + - run: + name: Run MAPL_Profiler Unit tests + command: | + cd build + make -j2 MAPL_Profiler_tests + ctest -R 'MAPL_Profiler_tests$' --output-on-failure + +workflows: + version: 2.1 + pull_request_tests: + jobs: + - build-and-test-GNU diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml new file mode 100644 index 000000000000..b03461cde922 --- /dev/null +++ b/.github/workflows/workflow.yml @@ -0,0 +1,54 @@ +name: Build MAPL + +on: pull_request + +jobs: + build_mapl: + runs-on: ubuntu-latest + container: gmao/geos-build-env-gcc-source:6.0.10 + env: + LANGUAGE: en_US.UTF-8 + LC_ALL: en_US.UTF-8 + LANG: en_US.UTF-8 + LC_TYPE: en_US.UTF-8 + OMPI_ALLOW_RUN_AS_ROOT: 1 + OMPI_ALLOW_RUN_AS_ROOT_CONFIRM: 1 + OMPI_MCA_btl_vader_single_copy_mechanism: none + steps: + - uses: actions/checkout@v2 + with: + fetch-depth: 1 + - name: Versions etc. + run: | + gfortran --version + mpirun --version + echo $BASEDIR + - name: Mepo clone external repos + run: | + mepo init + mepo clone + mepo status + - name: CMake + run: | + mkdir build + cd build + cmake .. -DBASEDIR=$BASEDIR/Linux -DCMAKE_Fortran_COMPILER=gfortran -DCMAKE_BUILD_TYPE=Debug -DMPIEXEC_PREFLAGS='--oversubscribe' + - name: Build + run: | + cd build + make -j4 install + - name: Run pFIO Unit tests + run: | + cd build + make -j4 pFIO_tests + ctest -R 'pFIO_tests$' --output-on-failure + - name: Run MAPL_Base Unit tests + run: | + cd build + make -j4 MAPL_Base_tests + ctest -R 'MAPL_Base_tests$' --output-on-failure + - name: Run MAPL_Profiler Unit tests + run: | + cd build + make -j4 MAPL_Profiler_tests + ctest -R 'MAPL_Profiler_tests$' --output-on-failure diff --git a/.gitignore b/.gitignore index 27391e5e9f7d..d597fe80d418 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,7 @@ *~ -/@cmake +/@cmake/ +/@env/ +/BUILD/ +/build*/ +/install*/ +/.mepo/ diff --git a/Apps/CMakeLists.txt b/Apps/CMakeLists.txt new file mode 100644 index 000000000000..8fdb68a70308 --- /dev/null +++ b/Apps/CMakeLists.txt @@ -0,0 +1 @@ +file (COPY MAPL_GridCompSpecs_ACG.py DESTINATION ${esma_etc}/MAPL) diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py new file mode 100755 index 000000000000..d3b0196a277b --- /dev/null +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -0,0 +1,306 @@ +#!/usr/bin/env python +import argparse +import sys +import os +import csv +import pandas as pd + + +############################################################### +class MAPL_DataSpec: + """Declare and manipulate an import/export/internal specs for a + MAPL Gridded component""" + + all_options = ['short_name', 'long_name', 'units', + 'dims', 'vlocation', 'num_subtiles', + 'refresh_interval', 'averaging_interval', 'halowidth', + 'precision','default','restart', 'ungridded_dims', + 'field_type', 'staggering', 'rotation', + 'friendlyto'] + + # The following arguments are skipped if value is empty string + optional_options = [ 'dims', 'vlocation', 'num_subtiles', + 'refresh_interval', 'averaging_interval', 'halowidth', + 'precision','default','restart', 'ungridded_dims', + 'field_type', 'staggering', 'rotation', + 'friendlyto'] + + # The following options require quotes in generated code + stringlike_options = ['short_name', 'long_name', 'units', 'friendlyto'] + + + # The following arguments must be placed within array brackets. + arraylike_options = ['ungridded_dims'] + + + def __init__(self, category, args, indent=3): + self.category = category + self.args = args + self.indent = indent + + def newline(self): + return "\n" + " "*self.indent + + def continue_line(self): + return "&" + self.newline() + "& " + + def emit_specs(self): + return self.emit_header() + self.emit_args() + self.emit_trailer() + + def get_rank(self): + ranks = {'MAPL_DimsHorzVert':3, 'MAPL_DimsHorzOnly':2, 'MAPL_DimsVertOnly':1} + extra_rank = 0 # unless + if 'ungridded_dims' in self.args: + ungridded = self.args['ungridded_dims'] + if ungridded: + extra_dims = ungridded.strip('][').split(',') + extra_rank = len(extra_dims) + return ranks[self.args['dims']] + extra_rank + + def emit_declare_pointers(self): + text = self.emit_header() + type = 'real' + if 'precision' in self.args: + kind = self.args['precision'] + else: + kind = None + rank = self.get_rank() + dimension = 'dimension(:' + ',:'*(rank-1) + ')' + text = text + type + if kind: + text = text + '(kind=' + str(kind) + ')' + text = text +', pointer, ' + dimension + ' :: ' + self.args['short_name'] + ' => null()' + text = text + self.emit_trailer() + return text + + def emit_get_pointers(self): + text = self.emit_header() + text = text + "call MAPL_GetPointer(" + self.category + ', ' + self.args['short_name'] + ", '" + self.args['short_name'] + "', rc=status); VERIFY_(status)" + text = text + self.emit_trailer() + return text + + def emit_header(self): + text = self.newline() + if 'CONDITION' in self.args and self.args['CONDITION']: + self.indent = self.indent + 3 + text = text + "if (" + self.args['CONDITION'] + ") then" + self.newline() + return text + + def emit_args(self): + self.indent = self.indent + 5 + text = "call MAPL_Add" + self.category.capitalize() + "Spec(gc," + self.continue_line() + for option in MAPL_DataSpec.all_options: + text = text + self.emit_arg(option) + text = text + 'rc=status)' + self.newline() + self.indent = self.indent - 5 + text = text + 'VERIFY_(status)' + return text + + def emit_arg(self, option): + text = '' + if option in self.args: + value = self.args[option] + if option in MAPL_DataSpec.optional_options: + if self.args[option] == '': + return '' + text = text + option + "=" + if option in MAPL_DataSpec.stringlike_options: + value = "'" + value + "'" + elif option in MAPL_DataSpec.arraylike_options: + value = '[' + value + ']' # convert to Fortran 1D array + text = text + value + ", " + self.continue_line() + return text + + def emit_trailer(self): + if 'CONDITION' in self.args and self.args['CONDITION']: + self.indent = self.indent - 3 + text = self.newline() + text = text + "endif" + self.newline() + else: + text = self.newline() + return text + + + + + +def read_specs(specs_filename): + + def csv_record_reader(csv_reader): + """ Read a csv reader iterator until a blank line is found. """ + prev_row_blank = True + for row in csv_reader: + if not (len(row) == 0): + if row[0].startswith('#'): + continue + yield [cell.strip() for cell in row] + prev_row_blank = False + elif not prev_row_blank: + return + + column_aliases = { + 'NAME' : 'short_name', + 'LONG NAME' : 'long_name', + 'VLOC' : 'vlocation', + 'UNITS' : 'units', + 'DIMS' : 'dims', + 'UNGRIDDED' : 'ungridded_dims', + 'PREC' : 'precision', + 'COND' : 'condition', + 'DEFAULT' : 'default', + 'RESTART' : 'restart', + 'FRIENDLYTO' : 'friendlyto' + } + + specs = {} + with open(specs_filename, 'r') as specs_file: + specs_reader = csv.reader(specs_file, skipinitialspace=True,delimiter='|') + gen = csv_record_reader(specs_reader) + schema_version = next(gen)[0].split(' ')[1] + component = next(gen)[0].split(' ')[1] +# print("Generating specification code for component: ",component) + while True: + try: + gen = csv_record_reader(specs_reader) + category = next(gen)[0].split()[1] + bare_columns = next(gen) + bare_columns = [c.strip() for c in bare_columns] + columns = [] + for c in bare_columns: + if c in column_aliases: + columns.append(column_aliases[c]) + else: + columns.append(c) + specs[category] = pd.DataFrame(gen, columns=columns) + except StopIteration: + break + + entry_aliases = {'z' : 'MAPL_DimsVertOnly', + 'xy' : 'MAPL_DimsHorzOnly', + 'xyz' : 'MAPL_DimsHorzVert', + 'C' : 'MAPL_VlocationCenter', + 'E' : 'MAPL_VlocationEdge', + 'N' : 'MAPL_VlocationNone', + 'OPT' : 'MAPL_RestartOptional', + 'SKIP' : 'MAPL_RestartSkip', + 'REQ' : 'MAPL_RestartRequired', + 'BOOT' : 'MAPL_RestartBoot', + 'SKIPI' : 'MAPL_RestartSkipInitial' + + } + + specs['IMPORT'].replace(entry_aliases,inplace=True) + specs['EXPORT'].replace(entry_aliases,inplace=True) + specs['INTERNAL'].replace(entry_aliases,inplace=True) + + return specs + + + +def header(): + """ + Returns a standard warning that can be placed at the top of each + generated _Fortran_ include file. + """ + + return """ +! ------------------- +! W A R N I N G +! ------------------- +! +! This code fragment is automatically generated by MAPL_GridCompSpecs_ACG. +! Please DO NOT edit it. Any modification made in here will be overwritten +! next time this file is auto-generated. Instead, enter your additions +! or deletions in the .rc file in the src tree. +! + """ + +def open_with_header(filename): + f = open(filename,'w') + f.write(header()) + return f + + + +############################################# +# Main program begins here +############################################# + + +# Process command line arguments +parser = argparse.ArgumentParser(description='Generate import/export/internal specs for MAPL Gridded Component') +parser.add_argument("input", action='store', + help="input filename") +parser.add_argument("-n", "--name", action="store", + help="override default grid component name derived from input filename") +parser.add_argument("-i", "--import_specs", action="store", nargs='?', + default=None, const="{component}_Import___.h", + help="override default output filename for AddImportSpec() code") +parser.add_argument("-x", "--export_specs", action="store", nargs='?', + default=None, const="{component}_Export___.h", + help="override default output filename for AddExternalSpec() code") +parser.add_argument("-p", "--internal_specs", action="store", nargs='?', + default=None, const="{component}_Internal___.h", + help="override default output filename for AddImportSpec() code") +parser.add_argument("-g", "--get-pointers", action="store", nargs='?', + default=None, const="{component}_GetPointer___.h", + help="override default output filename for get_pointer() code") +parser.add_argument("-d", "--declare-pointers", action="store", nargs='?', + const="{component}_DeclarePointer___.h", default=None, + help="override default output filename for AddSpec code") +args = parser.parse_args() + + +# Process blocked CSV input file using pandas +specs = read_specs(args.input) + +if args.name: + component = args.name +else: + component = os.path.splitext(os.path.basename(args.input))[0] + component = component.replace('_Registry','') + component = component.replace('_StateSpecs','') + +# open all output files +f_specs = {} +for category in ("IMPORT","EXPORT","INTERNAL"): + option = args.__dict__[category.lower()+"_specs"] + if option: + fname = option.format(component=component) + f_specs[category] = open_with_header(fname) + else: + f_specs[category] = None + +if args.declare_pointers: + f_declare_pointers = open_with_header(args.declare_pointers.format(component=component)) +else: + f_declare_pointers = None +if args.get_pointers: + f_get_pointers = open_with_header(args.get_pointers.format(component=component)) +else: + f_get_pointers = None + +# Generate code from specs (processed above with pandas) +for category in ("IMPORT","EXPORT","INTERNAL"): + for item in specs[category].to_dict("records"): + spec = MAPL_DataSpec(category.lower(), item) + if f_specs[category]: + f_specs[category].write(spec.emit_specs()) + if f_declare_pointers: + f_declare_pointers.write(spec.emit_declare_pointers()) + if f_get_pointers: + f_get_pointers.write(spec.emit_get_pointers()) + +# Close output files +for category, f in f_specs.items(): + if f: + f.close() +if f_declare_pointers: + f_declare_pointers.close() +if f_get_pointers: + f_get_pointers.close() + + + + + diff --git a/CHANGELOG.md b/CHANGELOG.md index 07b86dd295ef..340e7e002164 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,50 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [Unreleased] + +### Changed +### Fixed +### Removed +### Added + +## [2.1.0] 2020-04-16 + +### Changed + +- Corrected handling of Equation of Time in orbit (off by default) +- Made ASSERT in ExtData more explicit in case of missing variables. +- (re) Introduced MAPL Profiling package +- Improved diagnostic message in HistoryGridComp for misspelled fields/bundles +- Removed CVS keywords + +### Fixed + +- Corrected Python code generator scripts for component import/export specs. +- Add directories to `.gitignore` for building with `mepo` +- Bug building with mixed Intel/GCC compilers +- Implemented workaround to cmake error that happens when building tests in parallel. +- Set correct ESMA_env tag in `components.yaml` +- Updated `components.yaml` to be inline with GEOSgcm +- Minor problem in GMAO_pFIO Cmakelists (consistency with PRIVATE) + +### Removed + +- Removed support for `checkout_externals` and moved solely to `mepo` + - Removed `Externals.cfg` + - Removed `checkout_externals` code in `CMakeLists.txt` + +### Added + +- Added configuration for CircleCI and Github Actions + - Builds MAPL using GCC 9.2.0 and Open MPI 4.0.2 + - Builds and runs `pFIO_tests` and `MAPL_Base_tests` +- Add precession of equinox (not on by default) +- Imported Python/MAPL subdir (old, but never imported to GitHub) +- Python automatic code generator for grid comp include files +- Added support to use pFlogger for logging + - Command line option: --logging_config= + ## [2.0.6] - 2020-04-15 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 3399ad104eec..7370af60eef5 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,32 +4,45 @@ cmake_policy (SET CMP0054 NEW) project ( MAPL - VERSION 2.0 + VERSION 2.1.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF -if (NOT COMMAND esma) # build as standalone project - # Invoke checkout_ externals, but only the first time we - # configure. - if (NOT SKIP_MANAGE_EXTERNALS) - execute_process ( - COMMAND "checkout_externals" - WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} - ) - endif () - option (SKIP_MANAGE_EXTERNALS "Set to skip manage externals step" ON) - +if (EXISTS ${CMAKE_CURRENT_LIST_DIR}/@cmake) list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/@cmake") include (esma) +else () + if (NOT COMMAND esma) # build as standalone project + + if (NOT SKIP_MEPO) + set (MEPO_INIT_COMMAND mepo init) + execute_process ( + COMMAND ${MEPO_INIT_COMMAND} + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + ) + + set (MEPO_CLONE_COMMAND mepo clone) + execute_process ( + COMMAND ${MEPO_CLONE_COMMAND} + WORKING_DIRECTORY ${CMAKE_SOURCE_DIR} + ) + endif() + option (SKIP_MEPO "Set to skip mepo steps" ON) + + list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/@cmake") + include (esma) + endif() endif() ecbuild_declare_project() +find_package(PFLOGGER REQUIRED) # Special case - MAPL_cfio is built twice with two different precisions. add_subdirectory (MAPL_cfio MAPL_cfio_r4) add_subdirectory (MAPL_cfio MAPL_cfio_r8) add_subdirectory (GMAO_pFIO) +add_subdirectory (MAPL_Profiler) add_subdirectory (MAPL_Base) add_subdirectory (MAPL) @@ -37,6 +50,10 @@ if (PFUNIT_FOUND) add_subdirectory (MAPL_pFUnit EXCLUDE_FROM_ALL) endif () +# Support for automated code generation +list (APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_LIST_DIR}/cmake") +include(mapl_acg) +add_subdirectory (Apps) # Git transition defect: # Uncomment the line below once the dev branch of MAPL has been brought in. diff --git a/Externals.cfg b/Externals.cfg deleted file mode 100644 index 74cb29a7be6b..000000000000 --- a/Externals.cfg +++ /dev/null @@ -1,11 +0,0 @@ -[GEOS_cmake] -required = True -repo_url = git@github.com:GEOS-ESM/ESMA_cmake.git -local_path = ./@cmake -tag = v2.1.1 -externals = Externals.cfg -protocol = git - -[externals_description] -schema_version = 1.0.0 - diff --git a/GMAO_pFIO/AbstractServer.F90 b/GMAO_pFIO/AbstractServer.F90 index 8b351497cc17..9eacdfa98ca2 100644 --- a/GMAO_pFIO/AbstractServer.F90 +++ b/GMAO_pFIO/AbstractServer.F90 @@ -109,7 +109,6 @@ subroutine init(this,comm) integer, intent(in) :: comm integer :: ierror, MyColor - integer :: i call MPI_Comm_dup(comm, this%comm, ierror) call MPI_Comm_rank(this%comm, this%rank, ierror) @@ -289,6 +288,7 @@ subroutine get_DataFromMem(this,multi, rc) logical, intent(in) :: multi integer, optional, intent(out) :: rc _ASSERT(.false.," no action of server_get_DataFromMem") + _UNUSED_DUMMY(multi) end subroutine get_DataFromMem function am_I_reading_PE(this,id) result (yes) diff --git a/GMAO_pFIO/CMakeLists.txt b/GMAO_pFIO/CMakeLists.txt index 3b5a59e0d5b6..9ac4da334672 100644 --- a/GMAO_pFIO/CMakeLists.txt +++ b/GMAO_pFIO/CMakeLists.txt @@ -87,14 +87,13 @@ set (srcs ) esma_add_library (${this} SRCS ${srcs}) -target_link_libraries (${this} gftl gftl-shared ${NETCDF_LIBRARIES}) +target_link_libraries (${this} PUBLIC gftl gftl-shared + PRIVATE ${NETCDF_LIBRARIES} OpenMP::OpenMP_Fortran MPI::MPI_Fortran) -target_compile_options (${this} PRIVATE $<$:${OpenMP_Fortran_FLAGS}>) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) -target_link_libraries (${this} ${MPI_Fortran_LIBRARIES} ${OpenMP_Fortran_LIBRARIES}) # Kludge for OSX security and DYLD_LIBRARY_PATH ... foreach(dir ${OSX_EXTRA_LIBRARY_PATH}) - target_link_libraries(${this} "-Xlinker -rpath -Xlinker ${dir}") + target_link_libraries(${this} PRIVATE "-Xlinker -rpath -Xlinker ${dir}") endforeach() @@ -103,14 +102,14 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES GNU) ecbuild_add_executable ( TARGET pfio_server_demo.x SOURCES pfio_server_demo.F90 - LIBS ${this} ${NETCDF_LIBRARIES} ${OpenMP_Fortran_LIBRARIES}) + LIBS ${this} ${NETCDF_LIBRARIES} OpenMP::OpenMP_Fortran MPI::MPI_Fortran) set_target_properties (pfio_server_demo.x PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) set_target_properties(pfio_server_demo.x PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") ecbuild_add_executable ( TARGET pfio_collective_demo.x SOURCES pfio_collective_demo.F90 - LIBS ${this} ${NETCDF_LIBRARIES} ${OpenMP_Fortran_LIBRARIES}) + LIBS ${this} ${NETCDF_LIBRARIES} OpenMP::OpenMP_Fortran MPI::MPI_Fortran) set_target_properties (pfio_collective_demo.x PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) set_target_properties(pfio_collective_demo.x PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") endif () diff --git a/GMAO_pFIO/ClientManager.F90 b/GMAO_pFIO/ClientManager.F90 index 8f029f3b0402..ac5657a7f2e4 100644 --- a/GMAO_pFIO/ClientManager.F90 +++ b/GMAO_pFIO/ClientManager.F90 @@ -96,7 +96,7 @@ function add_hist_collection(this, fmd, unusable, rc) result(hist_collection_id) class (KeywordEnforcer), optional, intent(out) :: unusable integer, optional, intent(out) :: rc type (ClientThread), pointer :: clientPtr - integer :: i, i1,i2 + integer :: i do i = 1, this%size() ClientPtr => this%clients%at(i) @@ -138,7 +138,7 @@ subroutine prefetch_data(this, collection_id, file_name, var_name, data_referenc integer, optional, intent(out) :: rc type (ClientThread), pointer :: clientPtr - integer :: request_id, ith, status + integer :: request_id, status clientPtr =>this%current() request_id = clientPtr%prefetch_data(collection_id, file_name, var_name, data_reference, start=start, rc=status) diff --git a/GMAO_pFIO/ClientThread.F90 b/GMAO_pFIO/ClientThread.F90 index e85981651b87..5cf25ec4e5a7 100644 --- a/GMAO_pFIO/ClientThread.F90 +++ b/GMAO_pFIO/ClientThread.F90 @@ -444,9 +444,6 @@ end subroutine wait subroutine wait_all(this) use pFIO_AbstractRequestHandleMod class (ClientThread), target, intent(inout) :: this - integer :: request_id - type (IntegerRequestMapIterator) :: iter - integer :: status call this%clear_RequestHandle() !call this%shake_hand() diff --git a/GMAO_pFIO/DirectoryService.F90 b/GMAO_pFIO/DirectoryService.F90 index d034f7e50da9..2835653f2a9c 100644 --- a/GMAO_pFIO/DirectoryService.F90 +++ b/GMAO_pFIO/DirectoryService.F90 @@ -450,7 +450,6 @@ function sizeof_directory() result(sz) integer :: sz integer :: sizeof_char, sizeof_integer, sizeof_DirectoryEntry - integer :: ierror integer :: one_integer character :: one_char diff --git a/GMAO_pFIO/NetCDF4_FileFormatter.F90 b/GMAO_pFIO/NetCDF4_FileFormatter.F90 index d11aa8dbe7f3..f363303377d8 100644 --- a/GMAO_pFIO/NetCDF4_FileFormatter.F90 +++ b/GMAO_pFIO/NetCDF4_FileFormatter.F90 @@ -133,7 +133,7 @@ subroutine create(this, file, unusable, rc) integer :: status !$omp critical - status = nf90_create(file, NF90_NOCLOBBER + NF90_HDF5, this%ncid) + status = nf90_create(file, IOR(NF90_NOCLOBBER, NF90_NETCDF4), this%ncid) !$omp end critical _VERIFY(status) @@ -153,6 +153,7 @@ subroutine create_par(this, file, unusable, comm, info, rc) integer :: comm_ integer :: info_ integer :: status + integer :: mode if (present(comm)) then comm_ = comm @@ -170,8 +171,13 @@ subroutine create_par(this, file, unusable, comm, info, rc) this%comm = comm_ this%info = info_ + mode = NF90_NOCLOBBER + mode = IOR(mode, NF90_NETCDF4) + mode = IOR(mode, NF90_SHARE) + mode = IOR(mode, NF90_MPIIO) + !$omp critical - status = nf90_create(file, NF90_NOCLOBBER + NF90_NETCDF4 + NF90_SHARE + NF90_MPIIO, comm=comm_, info=info_, ncid=this%ncid) + status = nf90_create(file, mode, comm=comm_, info=info_, ncid=this%ncid) !$omp end critical _VERIFY(status) @@ -214,12 +220,12 @@ subroutine open(this, file, mode, unusable, comm, info, rc) if (this%parallel) then !$omp critical - status = nf90_open(file, omode + NF90_MPIIO, comm=this%comm, info=this%info, ncid=this%ncid) + status = nf90_open(file, IOR(omode, NF90_MPIIO), comm=this%comm, info=this%info, ncid=this%ncid) !$omp end critical _VERIFY(status) else !$omp critical - status = nf90_open(file, omode + NF90_SHARE, this%ncid) + status = nf90_open(file, IOR(omode, NF90_SHARE), this%ncid) !$omp end critical _VERIFY(status) end if diff --git a/GMAO_pFIO/ServerThread.F90 b/GMAO_pFIO/ServerThread.F90 index 8cae25726758..f7ad6e7d8187 100644 --- a/GMAO_pFIO/ServerThread.F90 +++ b/GMAO_pFIO/ServerThread.F90 @@ -160,9 +160,7 @@ subroutine run(this, rc) integer, optional, intent(out) :: rc class (AbstractMessage), pointer :: message - type(DoneMessage) :: dMessage class(AbstractSocket),pointer :: connection - logical :: all_backlog_is_empty integer :: status connection=>this%get_connection() @@ -770,7 +768,8 @@ subroutine handle_HandShake(this, message, rc) class(AbstractSocket),pointer :: connection type (DummyMessage) :: handshake_msg - integer :: status + + _UNUSED_DUMMY(message) connection=>this%get_connection() call connection%send(handshake_msg) @@ -1119,19 +1118,10 @@ recursive subroutine handle_Done_collective_stage(this, message, rc) type (CollectiveStageDoneMessage), intent(in) :: message integer, optional, intent(out) :: rc - type (LocalMemReference) :: mem_data_reference - class(AbstractDataReference),pointer :: dataRefPtr - class(AbstractMessage),pointer :: dMessage - integer :: data_status, node_rank, innode_rank - integer(kind=INT64) :: g_offset, offset,msize_word - type(c_ptr) :: offset_address - integer,pointer :: i_ptr(:) - type (MessageVectorIterator) :: iter - class (AbstractMessage), pointer :: msg - class(AbstractSocket),pointer :: connection - class (AbstractRequestHandle), pointer :: handle integer :: status + _UNUSED_DUMMY(message) + this%containing_server%serverthread_done_msgs(this%thread_rank) = .true. if ( .not. all(this%containing_server%serverthread_done_msgs)) then _RETURN(_SUCCESS) @@ -1158,19 +1148,14 @@ recursive subroutine handle_Done_stage(this, message, rc) type (StageDoneMessage), intent(in) :: message integer, optional, intent(out) :: rc - type (LocalMemReference) :: mem_data_reference - class(AbstractDataReference),pointer :: dataRefPtr - class(AbstractMessage),pointer :: dMessage - integer :: data_status, node_rank, innode_rank - integer(kind=INT64) :: g_offset, offset,msize_word - type(c_ptr) :: offset_address - integer,pointer :: i_ptr(:) type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg class(AbstractSocket),pointer :: connection class (AbstractRequestHandle), pointer :: handle integer :: status + _UNUSED_DUMMY(message) + if ( this%request_backlog%empty()) then _RETURN(_SUCCESS) endif @@ -1209,16 +1194,9 @@ recursive subroutine handle_Done_prefetch(this, message, rc) integer, optional, intent(out) :: rc type (LocalMemReference) :: mem_data_reference - class(AbstractDataReference),pointer :: dataRefPtr - class(AbstractMessage),pointer :: dMessage - integer :: data_status, node_rank, innode_rank - integer(kind=INT64) :: g_offset, offset,msize_word - type(c_ptr) :: offset_address - integer,pointer :: i_ptr(:) type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg class(AbstractSocket),pointer :: connection - class (AbstractRequestHandle), pointer :: handle integer :: status iter = this%request_backlog%begin() @@ -1255,17 +1233,7 @@ recursive subroutine handle_Done_collective_prefetch(this, message, rc) type (CollectivePrefetchDoneMessage), intent(in) :: message integer, optional, intent(out) :: rc - type (LocalMemReference) :: mem_data_reference class(AbstractDataReference),pointer :: dataRefPtr - class(AbstractMessage),pointer :: dMessage - integer :: data_status, node_rank, innode_rank - integer(kind=INT64) :: g_offset, offset,msize_word - type(c_ptr) :: offset_address - integer,pointer :: i_ptr(:) - type (MessageVectorIterator) :: iter - class (AbstractMessage), pointer :: msg - class(AbstractSocket),pointer :: connection - class (AbstractRequestHandle), pointer :: handle integer :: status ! first time handling the "Done" message, simple return @@ -1299,15 +1267,13 @@ subroutine get_DataFromMem( this, multi_data_read, rc) integer, optional, intent(out) :: rc type (LocalMemReference) :: mem_data_reference class(AbstractDataReference),pointer :: dataRefPtr - class(AbstractMessage),pointer :: dMessage - integer :: data_status, node_rank, innode_rank + integer :: node_rank, innode_rank integer(kind=INT64) :: g_offset, offset,msize_word type(c_ptr) :: offset_address integer,pointer :: i_ptr(:) type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg class(AbstractSocket),pointer :: connection - class (AbstractRequestHandle), pointer :: handle integer :: status connection=>this%get_connection(status) diff --git a/GMAO_pFIO/new_overload.macro b/GMAO_pFIO/new_overload.macro index 5e1e1be2626e..dd7f84d3f35e 100644 --- a/GMAO_pFIO/new_overload.macro +++ b/GMAO_pFIO/new_overload.macro @@ -1,4 +1,3 @@ -! $Id$ #ifdef _TYPE #undef _TYPE diff --git a/GMAO_pFIO/pFIO_ErrLog.h b/GMAO_pFIO/pFIO_ErrLog.h index b2a1ee661e2c..8dd96e78b5ba 100644 --- a/GMAO_pFIO/pFIO_ErrLog.h +++ b/GMAO_pFIO/pFIO_ErrLog.h @@ -1,5 +1,4 @@ -! $Id$ ! The error logging may eventually evolve into a module based ! on the ESMF logger. For now these macros provide simple diff --git a/GMAO_pFIO/pfio_collective_demo.F90 b/GMAO_pFIO/pfio_collective_demo.F90 index 70d90d7fdead..5969fe7712c3 100644 --- a/GMAO_pFIO/pfio_collective_demo.F90 +++ b/GMAO_pFIO/pfio_collective_demo.F90 @@ -307,7 +307,6 @@ program main integer :: rank, npes, ierror, provided,required integer :: status, color, key - class(AbstractServer),allocatable,target :: s class(AbstractServer),pointer :: server class(AbstractDirectoryService), pointer :: d_s => null() @@ -368,6 +367,8 @@ function get_directory_service(stype) result(d_s) allocate(d_s, source=DirectoryService(MPI_COMM_WORLD)) + _UNUSED_DUMMY(stype) + end function function split_color(stype,split_rank) result(color) diff --git a/GMAO_pFIO/pfio_server_demo.F90 b/GMAO_pFIO/pfio_server_demo.F90 index e9e5c4525b01..926f4801c2ff 100644 --- a/GMAO_pFIO/pfio_server_demo.F90 +++ b/GMAO_pFIO/pfio_server_demo.F90 @@ -201,10 +201,11 @@ subroutine run(this, step) type (ArrayReference) :: ref - integer :: i_var,i + integer :: i_var + !integer :: i integer :: lat0, lat1, nlats integer :: collection_id - character(len=4) :: tmp + !character(len=4) :: tmp lat0 = 1 + (this%rank*this%nlat)/this%npes lat1 = (this%rank+1)*this%nlat/this%npes @@ -258,7 +259,6 @@ end subroutine run subroutine finalize(this) class (FakeExtData), intent(inout) :: this - integer :: ierror deallocate(this%bundle) call this%c%terminate() end subroutine finalize diff --git a/GMAO_pFIO/tests/CMakeLists.txt b/GMAO_pFIO/tests/CMakeLists.txt index f1fd856d988b..e80abdf18546 100644 --- a/GMAO_pFIO/tests/CMakeLists.txt +++ b/GMAO_pFIO/tests/CMakeLists.txt @@ -19,7 +19,6 @@ set (TEST_SRCS # SRCS are mostly mocks to facilitate tests set (SRCS - pFIO_Initialize.F90 MockServerThread.F90 MockClientThread.F90 MockClient.F90 @@ -27,10 +26,19 @@ set (SRCS MockSocket.F90 ) +# This file needs to be in a library because CMake cannot detect the +# dependency of the pFUnit driver on it. This is due to the use of +# preprocesor in the driver for specifying the include file. +add_library (pfio_extras + pFIO_Initialize.F90 + ) +target_link_libraries (pfio_extras PUBLIC MAPL_pFUnit) + + add_pfunit_ctest(pFIO_tests TEST_SOURCES ${TEST_SRCS} OTHER_SOURCES ${SRCS} - LINK_LIBRARIES GMAO_pFIO MAPL_pFUnit + LINK_LIBRARIES GMAO_pFIO pfio_extras MAPL_pFUnit EXTRA_INITIALIZE Initialize EXTRA_USE pFIO_pFUNIT_Initialize MAX_PES 8 @@ -44,7 +52,6 @@ include_directories( include_directories(${CMAKE_CURRENT_SOURCE_DIR}/..) include_directories(${CMAKE_CURRENT_BINARY_DIR}/..) include_directories(${include_GMAO_pFIO}) -include_directories(${include_MAPL_pFUnit}) set(TESTO pfio_ctest_io.x) @@ -52,7 +59,7 @@ ecbuild_add_executable ( TARGET ${TESTO} PROPERTIES EXCLUDE_FROM_ALL=TRUE SOURCES pfio_ctest_io.F90 - LIBS GMAO_pFIO ${NETCDF_LIBRARIES} + LIBS GMAO_pFIO ${NETCDF_LIBRARIES} MPI::MPI_Fortran DEFINITIONS USE_MPI) set_target_properties(${TESTO} PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") target_link_libraries(${TESTO} GMAO_pFIO ${NETCDF_LIBRARIES}) @@ -84,7 +91,7 @@ ecbuild_add_executable ( PROPERTIES EXCLUDE_FROM_ALL=TRUE SOURCES pfio_performance.F90 DEFINITIONS USE_MPI - LIBS GMAO_pFIO ${NETCDF_LIBRARIES}) + LIBS GMAO_pFIO ${NETCDF_LIBRARIES} MPI::MPI_Fortran) set_target_properties(${TESTPERF} PROPERTIES LINK_FLAGS "${OpenMP_Fortran_FLAGS}") target_link_libraries(${TESTPERF} GMAO_pFIO ${NETCDF_LIBRARIES}) diff --git a/GMAO_pFIO/tests/MockClient.F90 b/GMAO_pFIO/tests/MockClient.F90 index 494d342176eb..a5820aadff00 100644 --- a/GMAO_pFIO/tests/MockClient.F90 +++ b/GMAO_pFIO/tests/MockClient.F90 @@ -1,3 +1,5 @@ +#include "unused_dummy.H" + module MockClientMod use pFIO_ClientThreadMod implicit none @@ -16,6 +18,7 @@ module MockClientMod function new_MockClient() result(c) type (MockClient) :: c + _UNUSED_DUMMY(c) end function new_MockClient diff --git a/GMAO_pFIO/tests/Test_UnlimitedEntity.pf b/GMAO_pFIO/tests/Test_UnlimitedEntity.pf index e1e4a52145db..567321c89df4 100644 --- a/GMAO_pFIO/tests/Test_UnlimitedEntity.pf +++ b/GMAO_pFIO/tests/Test_UnlimitedEntity.pf @@ -62,7 +62,6 @@ contains @test subroutine test_is_empty() type (UnlimitedEntity) :: a - character(len=:), allocatable:: str logical :: is ! not initialized diff --git a/GMAO_pFIO/tests/Test_pFIO_Utilities.pf b/GMAO_pFIO/tests/Test_pFIO_Utilities.pf index 80d3bd4bb3b7..be5a18108b11 100644 --- a/GMAO_pFIO/tests/Test_pFIO_Utilities.pf +++ b/GMAO_pFIO/tests/Test_pFIO_Utilities.pf @@ -117,7 +117,7 @@ contains @test subroutine test_serialize_string() - character(len=:), allocatable :: str + !character(len=:), allocatable :: str !call check(str); if (anyExceptions()) return call check(''); if (anyExceptions()) return diff --git a/GMAO_pFIO/tests/pfio_ctest_io.F90 b/GMAO_pFIO/tests/pfio_ctest_io.F90 index 6ed049172c11..ced27961c600 100644 --- a/GMAO_pFIO/tests/pfio_ctest_io.F90 +++ b/GMAO_pFIO/tests/pfio_ctest_io.F90 @@ -470,13 +470,12 @@ program main integer, parameter :: CLIENT_COLOR = 2 integer, parameter :: BOTH_COLOR = 3 - integer :: comm,num_threads type (FakeHistData0), target :: HistData integer :: my_comm_world, my_iComm, my_oComm, my_appcomm - integer :: client_start, size_group,low_rank,up_rank - integer :: local_rank, local_size, i,k, size_iclient, size_oclient + integer :: client_start, low_rank,up_rank + integer :: i,k, size_iclient, size_oclient integer :: app_start_rank, app_end_rank character(len = 20) :: out_file character(len = 100):: cmd diff --git a/MAPL_Base/CMakeLists.txt b/MAPL_Base/CMakeLists.txt index 548133241a1d..4f740e6c043b 100644 --- a/MAPL_Base/CMakeLists.txt +++ b/MAPL_Base/CMakeLists.txt @@ -27,6 +27,7 @@ set (srcs MAPL_CapGridComp.F90 MAPL_GridType.F90 MAPL_GridSpec.F90 MAPL_VerticalMethods.F90 MAPL_newCFIOitem.F90 + MAPL_EtaHybridVerticalCoordinate.F90 MAPL_VerticalInterpMod.F90 MAPL_ESMFTimeVectorMod.F90 MAPL_TimeMethods.F90 MAPL_ioClients.F90 MAPL_DirPath.F90 @@ -63,9 +64,16 @@ set (srcs FileMetadataUtilities.F90 FileMetadataUtilitiesVector.F90 ) -esma_add_library(${this} SRCS ${srcs} DEPENDENCIES GMAO_pFIO MAPL_cfio_r4 gftl-shared FLAP::FLAP) +esma_add_library( + ${this} SRCS ${srcs} + DEPENDENCIES MAPL_Profiler GMAO_pFIO MAPL_cfio_r4 pflogger gftl-shared FLAP::FLAP MPI::MPI_Fortran) target_compile_options (${this} PRIVATE $<$:${OpenMP_Fortran_FLAGS}>) +if(DISABLE_GLOBAL_NAME_WARNING) + target_compile_options (${this} PRIVATE $<$:${DISABLE_GLOBAL_NAME_WARNING}>) +endif() target_compile_definitions (${this} PRIVATE TWO_SIDED_COMM MAPL_MODE) +target_include_directories (${this} PRIVATE ${MAPL_SOURCE_DIR}/include) + if (NOT (CMAKE_BUILD_TYPE MATCHES Debug)) target_compile_definitions(${this} PRIVATE BUILD_TYPE_IS_NOT_DEBUG) @@ -99,7 +107,7 @@ target_link_libraries (${this} PUBLIC ${ESMF_LIBRARIES} ${MPI_Fortran_LIBRARIES} # We could leave these in the source directory, and just broaden the search path # in the other libaries, but this make it explicit which aspects are externally # used. -file (COPY unused_dummy.H DESTINATION ${esma_include}/${this}) +file (COPY ${MAPL_SOURCE_DIR}/include/unused_dummy.H DESTINATION ${esma_include}/${this}) file (COPY MAPL_Generic.h DESTINATION ${esma_include}/${this}) file (COPY MAPL_Exceptions.h DESTINATION ${esma_include}/${this}) file (COPY MAPL_ErrLog.h DESTINATION ${esma_include}/${this}) diff --git a/MAPL_Base/ESMFL_Mod.F90 b/MAPL_Base/ESMFL_Mod.F90 index 1817ba2e7115..ac4d8414bdd5 100644 --- a/MAPL_Base/ESMFL_Mod.F90 +++ b/MAPL_Base/ESMFL_Mod.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" #if 0 diff --git a/MAPL_Base/FileMetadataUtilities.F90 b/MAPL_Base/FileMetadataUtilities.F90 index 921d69e75fd0..fcda36a44d7b 100644 --- a/MAPL_Base/FileMetadataUtilities.F90 +++ b/MAPL_Base/FileMetadataUtilities.F90 @@ -227,8 +227,8 @@ function is_var_present(this,var_name,rc) result(isPresent) integer, optional, intent(out) :: rc logical :: isPresent - integer :: status class(Variable), pointer :: var + _UNUSED_DUMMY(rc) var => this%get_variable(var_name) isPresent = associated(var) @@ -340,8 +340,8 @@ function get_level_name(this,rc) result(lev_name) lev_name=var_name _RETURN(_SUCCESS) else + if (var%is_attribute_present('units')) then units => this%get_variable_attribute(var_name,'units') - if (associated(units)) then if (trim(units) .eq. 'hPa' .or. trim(units) .eq. 'sigma_level' .or. & trim(units) .eq. 'mb' .or. trim(units) .eq. 'millibar') then lev_name=var_name diff --git a/MAPL_Base/GetFieldArray.H b/MAPL_Base/GetFieldArray.H index 1009e9d2f4dc..c4b91bf0850b 100644 --- a/MAPL_Base/GetFieldArray.H +++ b/MAPL_Base/GetFieldArray.H @@ -16,7 +16,6 @@ real(KIND=EKIND_), pointer :: PTR DIMENSIONS_ integer, optional, intent( OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm=SUBSTR_ integer :: STATUS logical :: hasDE diff --git a/MAPL_Base/GetPointer.H b/MAPL_Base/GetPointer.H index 7a6cb5cf5020..b660375ddcea 100644 --- a/MAPL_Base/GetPointer.H +++ b/MAPL_Base/GetPointer.H @@ -19,7 +19,6 @@ logical, optional, intent(IN ) :: notFoundOK integer, optional, intent( OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm=SUBSTR_ integer :: STATUS type (ESMF_FieldBundle) :: bundle diff --git a/MAPL_Base/MAPL_AbstractGridFactory.F90 b/MAPL_Base/MAPL_AbstractGridFactory.F90 index 0b0e16a90f5c..145d28f211df 100644 --- a/MAPL_Base/MAPL_AbstractGridFactory.F90 +++ b/MAPL_Base/MAPL_AbstractGridFactory.F90 @@ -74,6 +74,9 @@ module MAPL_AbstractGridFactoryMod procedure(append_metadata), deferred :: append_metadata procedure(get_grid_vars), deferred :: get_grid_vars procedure(append_variable_metadata), deferred :: append_variable_metadata + procedure(generate_file_bounds), deferred :: generate_file_bounds + procedure(generate_file_reference2D), deferred :: generate_file_reference2D + procedure(generate_file_reference3D), deferred :: generate_file_reference3D end type AbstractGridFactory abstract interface @@ -168,6 +171,34 @@ subroutine append_variable_metadata(this,var) type(Variable), intent(inout) :: var end subroutine append_variable_metadata + subroutine generate_file_bounds(this,grid,local_start,global_start,global_count,rc) + use esmf + import AbstractGridFactory + class (AbstractGridFactory), intent(inout) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, allocatable, intent(inout) :: local_start(:) + integer, allocatable, intent(inout) :: global_start(:) + integer, allocatable, intent(inout) :: global_count(:) + integer, optional, intent(out) :: rc + + end subroutine generate_file_bounds + + function generate_file_reference2D(this,fpointer) result(ref) + use pFIO + import AbstractGridFactory + type(ArrayReference) :: ref + class (AbstractGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:) + end function generate_file_reference2D + + function generate_file_reference3D(this,fpointer) result(ref) + use pFIO + import AbstractGridFactory + type(ArrayReference) :: ref + class (AbstractGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:,:) + end function generate_file_reference3D + end interface character(len=*), parameter :: MOD_NAME = 'MAPL_AbstractGridFactory::' @@ -334,6 +365,8 @@ subroutine spherical_to_cartesian_2d_real32(this,u,v,xyz,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'spherical_to_cartesian_2d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) _ASSERT(im == size(v,1), 'u-v shape mismatch for IM') @@ -376,6 +409,8 @@ subroutine spherical_to_cartesian_2d_real64(this,u,v,xyz,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'spherical_to_cartesian_2d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) _ASSERT(im == size(v,1), 'u-v shape mismatch for IM') @@ -418,6 +453,8 @@ subroutine spherical_to_cartesian_3d_real32(this,u,v,xyz,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'spherical_to_cartesian_3d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) km = size(u,3) @@ -464,6 +501,8 @@ subroutine spherical_to_cartesian_3d_real64(this,u,v,xyz,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'spherical_to_cartesian_3d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) km = size(u,3) @@ -510,6 +549,8 @@ subroutine cartesian_to_spherical_2d_real32(this,xyz,u,v,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'cartesian_to_spherical_2d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) _ASSERT(im == size(v,1), 'u-v shape mismatch for IM') @@ -556,6 +597,8 @@ subroutine cartesian_to_spherical_2d_real64(this,xyz,u,v,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'cartesian_to_spherical_2d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) _ASSERT(im == size(v,1), 'u-v shape mismatch for IM') @@ -602,6 +645,8 @@ subroutine cartesian_to_spherical_3d_real32(this,xyz,u,v,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'cartesian_to_spherical_3d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) km = size(u,3) @@ -650,6 +695,8 @@ subroutine cartesian_to_spherical_3d_real64(this,xyz,u,v,basis,unusable,rc) character(len=*), parameter :: Iam= MOD_NAME // 'cartesian_to_spherical_3d' integer :: status + _UNUSED_DUMMY(unusable) + im = size(u,1) jm = size(u,2) km = size(u,3) @@ -696,6 +743,8 @@ function get_basis(this,basis,unusable,rc) result(basis_vectors) real(REAL64), pointer :: Xcoord(:,:) => null() real(REAL64), pointer :: Ycoord(:,:) => null() + _UNUSED_DUMMY(unusable) + _ASSERT(allocated(this%grid), 'grid not allocated') select case (basis) case ('north-south') @@ -771,6 +820,8 @@ function ComputeGridBasis(grid,unusable,rc) result(basis) real(REAL64) :: p1(2),p2(2),p3(2),p4(2),c1(2) integer :: i, j, im, jm, counts(3) + _UNUSED_DUMMY(unusable) + call MAPL_GridGet(grid,localCellCountPerDim=counts,rc=status) _VERIFY(status) im=counts(1) @@ -822,6 +873,8 @@ function ComputeXYZBasis(grid_basis,unusable,rc) result(basis) integer :: im, jm, i, j real(real64) :: dp,fac + _UNUSED_DUMMY(unusable) + im = size(grid_basis,3) jm = size(grid_basis,4) allocate(basis(3,2,im,jm),stat=status) diff --git a/MAPL_Base/MAPL_AbstractRegridder.F90 b/MAPL_Base/MAPL_AbstractRegridder.F90 index 8b9355eb0d86..081a1167ebb0 100644 --- a/MAPL_Base/MAPL_AbstractRegridder.F90 +++ b/MAPL_Base/MAPL_AbstractRegridder.F90 @@ -196,6 +196,7 @@ subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) _UNUSED_DUMMY(this) _UNUSED_DUMMY(u_in) _UNUSED_DUMMY(v_in) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -217,6 +218,7 @@ subroutine regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rotate, rc) _UNUSED_DUMMY(this) _UNUSED_DUMMY(u_in) _UNUSED_DUMMY(v_in) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -237,6 +239,7 @@ subroutine regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) _UNUSED_DUMMY(this) _UNUSED_DUMMY(u_in) _UNUSED_DUMMY(v_in) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -583,6 +586,7 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot _UNUSED_DUMMY(v_in) _UNUSED_DUMMY(u_out) _UNUSED_DUMMY(v_out) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -607,6 +611,7 @@ subroutine transpose_regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rot _UNUSED_DUMMY(v_in) _UNUSED_DUMMY(u_out) _UNUSED_DUMMY(v_out) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -631,6 +636,7 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot _UNUSED_DUMMY(v_in) _UNUSED_DUMMY(u_out) _UNUSED_DUMMY(v_out) + _UNUSED_DUMMY(rotate) u_out = 0 v_out = 0 _RETURN(_FAILURE) @@ -943,6 +949,7 @@ end function get_spec function isTranspose(this) result(amTranspose) logical :: amTranspose class (AbstractRegridder), intent(in) :: this + _UNUSED_DUMMY(this) amTranspose = .false. end function isTranspose diff --git a/MAPL_Base/MAPL_Base.F90 b/MAPL_Base/MAPL_Base.F90 index b73cec33389e..5b31494511e3 100644 --- a/MAPL_Base/MAPL_Base.F90 +++ b/MAPL_Base/MAPL_Base.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" #include "unused_dummy.H" @@ -2302,7 +2301,6 @@ function MAPL_LatLonGridCreate (Name, vm, & real :: LastOut(2) integer :: STATUS - character(len=ESMF_MAXSTR) :: IAm='MAPL_LatLonGridCreate' ! ------ @@ -2584,7 +2582,6 @@ subroutine MAPL_GRID_INTERIOR(GRID,I1,IN,J1,JN) type (ESMF_DistGrid) :: distGrid type(ESMF_DELayout) :: LAYOUT - type (ESMF_VM) :: vm integer, allocatable :: AL(:,:) integer, allocatable :: AU(:,:) integer :: nDEs,localDECount @@ -2626,7 +2623,6 @@ subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) real(ESMF_KIND_R8), intent(INOUT) :: gridCornerLats(:,:) integer, optional, intent( OUT) :: RC integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_GridGetCorners" type(ESMF_RouteHandle) :: rh type(ESMF_Field) :: field @@ -2685,7 +2681,6 @@ subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, RC) ! local vars integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_GridGet" integer :: mincounts(ESMF_MAXDIM) integer :: maxcounts(ESMF_MAXDIM) @@ -2920,7 +2915,6 @@ subroutine MAPL_GetImsJms(Imins,Imaxs,Jmins,Jmaxs,Ims,Jms,rc) integer, allocatable :: Im0(:), Jm0(:) integer :: minI,minJ ! in case the starting index is zero integer :: status - character*(14) :: Iam="MAPL_GetImsJms" _ASSERT(.not.associated(Ims), 'Ims is associated and should not be.') _ASSERT(.not.associated(Jms), 'Jms is associated and should not be.') @@ -3451,7 +3445,6 @@ subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid,IMGlob,JMGlob ! Currently the lat/lon grid is asumed to go from -180 to 180 !EOPI - character(len=ESMF_MAXSTR) :: Iam integer :: status integer :: IM_World, JM_World, dims(3) diff --git a/MAPL_Base/MAPL_CFIO.F90 b/MAPL_Base/MAPL_CFIO.F90 index 87925452f8d2..50e4005fb4b3 100644 --- a/MAPL_Base/MAPL_CFIO.F90 +++ b/MAPL_Base/MAPL_CFIO.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_Generic.h" #define MPI_NULL_TAG 99 @@ -399,7 +398,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, integer :: Comm, nPEs integer :: hours, mins, secs, timeInc integer :: I, J, LT, K, IMO, JMO, LMG, IML, JML - integer :: IMSUB, JMSUB, IMBEG, IMEND, JMBEG, JMEND + integer :: IMBEG, IMEND, JMBEG, JMEND integer :: Field_Type integer :: Df integer :: Num2DVars, Num3dVars @@ -6528,10 +6527,8 @@ subroutine GetTIndex(cfio,time,tindex,rc) integer :: tindex integer, optional, intent(out ) :: rc - __Iam__('GetTindex') - integer(ESMF_KIND_I4) :: iyr,imm,idd,ihr,imn,isc - integer :: i + integer :: i,status integer(ESMF_KIND_I8) :: iCurrInterval integer :: nhmsB, nymdB integer :: begDate, begTime @@ -6563,10 +6560,8 @@ subroutine MAPL_CFIOGetTimeFromIndex(mcfio,tindex,time,rc) integer, intent(in) :: tindex integer, optional, intent(out ) :: rc - __Iam__('MAPL_CFIOGetTimeFromIndex') - integer(ESMF_KIND_I4) :: iyr,imm,idd,ihr,imn,isc - integer :: i + integer :: i,status integer(ESMF_KIND_I8) :: iCurrInterval integer :: nhmsB, nymdB integer :: begDate, begTime diff --git a/MAPL_Base/MAPL_Cap.F90 b/MAPL_Base/MAPL_Cap.F90 index ee55696df912..6ee61d6159a9 100644 --- a/MAPL_Base/MAPL_Cap.F90 +++ b/MAPL_Base/MAPL_Cap.F90 @@ -14,8 +14,12 @@ module MAPL_CapMod use MAPL_BaseMod use MAPL_ErrorHandlingMod use pFIO + use MAPL_Profiler use MAPL_ioClientsMod use MAPL_CapOptionsMod + use pflogger, only: initialize_pflogger => initialize + use pflogger, only: logging + use pflogger, only: Logger implicit none private @@ -34,7 +38,7 @@ module MAPL_CapMod logical :: mpi_already_initialized = .false. type(MAPL_CapGridComp), public :: cap_gc - type (SplitCommunicator) :: split_comm + type(SplitCommunicator) :: split_comm type(MAPL_Communicators) :: mapl_comm type(MpiServer), pointer :: i_server=>null() type(MpiServer), pointer :: o_server=>null() @@ -87,6 +91,7 @@ function new_MAPL_Cap(name, set_services, unusable, cap_options, rc) result(cap) class ( MAPL_CapOptions), optional, intent(in) :: cap_options integer, optional, intent(out) :: rc integer :: status + type(Logger), pointer :: lgr cap%name = name cap%set_services => set_services @@ -105,9 +110,18 @@ function new_MAPL_Cap(name, set_services, unusable, cap_options, rc) result(cap) endif call cap%initialize_mpi(rc=status) - _VERIFY(status) + call initialize_pflogger() + if (cap%cap_options%logging_config /= '') then + call logging%load_file(cap%cap_options%logging_config) + else + if (cap%rank == 0) then + lgr => logging%get_logger('MAPL') + call lgr%warning('No configure file specified for logging layer. Using defaults.') + end if + end if + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) end function new_MAPL_Cap @@ -119,13 +133,15 @@ subroutine run(this, unusable, rc) class (MAPL_Cap), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status +! + _UNUSED_DUMMY(unusable) call this%run_ensemble(rc=status); _VERIFY(status) call this%finalize_mpi(rc=status); _VERIFY(status) + _RETURN(_SUCCESS) end subroutine run @@ -416,8 +432,16 @@ subroutine run_model(this, mapl_comm, unusable, rc) type (ESMF_VM) :: vm integer :: start_tick, stop_tick, tick_rate integer :: status +! +! profiler +! + class (BaseProfiler), pointer :: t_p + _UNUSED_DUMMY(unusable) + t_p => get_global_time_profiler() + t_p = TimeProfiler('All', comm_world = mapl_comm%esmf%comm) + call t_p%start() call start_timer() call ESMF_Initialize (vm=vm, logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=mapl_comm%esmf%comm, rc=status) @@ -433,11 +457,14 @@ subroutine run_model(this, mapl_comm, unusable, rc) _VERIFY(status) call this%cap_gc%finalize(rc=status) _VERIFY(status) -!!$ call ESMF_Finalize(rc=status) -!!$ _VERIFY(status) - + !call ESMF_Finalize(rc=status) + !_VERIFY(status) call stop_timer() + + call t_p%stop() + call report_profiling() + ! W.J note : below reporting will be remove soon call report_throughput() _RETURN(_SUCCESS) @@ -472,8 +499,56 @@ subroutine report_throughput(rc) end subroutine report_throughput - end subroutine run_model + subroutine report_profiling(rc) + integer, optional, intent(out) :: rc + type (ProfileReporter) :: reporter + integer :: i + character(:), allocatable :: report_lines(:) + type (MultiColumn) :: inclusive + type (MultiColumn) :: exclusive + integer :: npes, my_rank, rank, ierror + character(1) :: empty(0) + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(50, separator= " ")) + call reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn(),separator='-')) + + inclusive = MultiColumn(['Inclusive'], separator='=') + call inclusive%add_column(FormattedTextColumn(' T (sec) ','(f9.3)', 9, InclusiveColumn(), separator='-')) + call inclusive%add_column(FormattedTextColumn(' % ','(f6.2)', 6, PercentageColumn(InclusiveColumn(),'MAX'),separator='-')) + call reporter%add_column(inclusive) + + exclusive = MultiColumn(['Exclusive'], separator='=') + call exclusive%add_column(FormattedTextColumn(' T (sec) ','(f9.3)', 9, ExclusiveColumn(), separator='-')) + call exclusive%add_column(FormattedTextColumn(' % ','(f6.2)', 6, PercentageColumn(ExclusiveColumn()), separator='-')) + call reporter%add_column(exclusive) + +!!$ call reporter%add_column(FormattedTextColumn(' std. dev ','(f12.4)', 12, StdDevColumn())) +!!$ call reporter%add_column(FormattedTextColumn(' rel. dev ','(f12.4)', 12, StdDevColumn(relative=.true.))) +!!$ call reporter%add_column(FormattedTextColumn(' max cyc ','(f12.8)', 12, MaxCycleColumn())) +!!$ call reporter%add_column(FormattedTextColumn(' min cyc ','(f12.8)', 12, MinCycleColumn())) +!!$ call reporter%add_column(FormattedTextColumn(' mean cyc','(f12.8)', 12, MeanCycleColumn())) +!!$ call mem_reporter%add_column(NameColumn(50,separator='-')) +!!$ call mem_reporter%add_column(MemoryTextColumn(['RSS'],'(i10,1x,a2)',13, InclusiveColumn(),separator='-')) +!!$ call mem_reporter%add_column(MemoryTextColumn(['Cyc RSS'],'(i10,1x,a2)',13, MeanCycleColumn(),separator='-')) + +!!$ report_lines = reporter%generate_report(get_global_time_profiler()) + + call MPI_Comm_size(mapl_comm%esmf%comm, npes, ierror) + call MPI_Comm_Rank(mapl_comm%esmf%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(mapl_comm%esmf%comm, ierror) + + end subroutine report_profiling + end subroutine run_model subroutine initialize_cap_gc(this, mapl_comm) class(MAPL_Cap), intent(inout) :: this diff --git a/MAPL_Base/MAPL_CapGridComp.F90 b/MAPL_Base/MAPL_CapGridComp.F90 index 926c8b20ba08..526a9912c505 100644 --- a/MAPL_Base/MAPL_CapGridComp.F90 +++ b/MAPL_Base/MAPL_CapGridComp.F90 @@ -6,6 +6,7 @@ module MAPL_CapGridCompMod use MAPL_ErrorHandlingMod use MAPL_BaseMod use MAPL_ConstantsMod + use MAPL_Profiler, only: BaseProfiler, get_global_time_profiler, get_global_memory_profiler use MAPL_ProfMod use MAPL_MemUtilsMod use MAPL_IOMod @@ -23,6 +24,7 @@ module MAPL_CapGridCompMod use MAPL_DirPathMod use pFIO use gFTL_StringVector + use pflogger, only: logging, Logger use iso_fortran_env @@ -30,7 +32,6 @@ module MAPL_CapGridCompMod private character(*), parameter :: internal_cap_name = "InternalCapGridComp" - character(*), parameter :: internal_meta_comp_name = "InternalCapMetaComp" public :: MAPL_CapGridComp, MAPL_CapGridCompCreate, MAPL_CapGridComp_Wrapper @@ -42,7 +43,7 @@ module MAPL_CapGridCompMod type (MAPL_Communicators) :: mapl_comm !!$ integer :: mapl_comm integer :: nsteps, heartbeat_dt, perpetual_year, perpetual_month, perpetual_day - logical :: amiroot, lperp + logical :: amiroot, lperp, started_loop_timer integer :: extdata_id, history_id, root_id, printspec type(ESMF_Clock) :: clock, clock_hist type(ESMF_Config) :: cf_ext, cf_root, cf_hist, config @@ -69,10 +70,6 @@ module MAPL_CapGridCompMod type(MAPL_CapGridComp), pointer :: ptr => null() end type MAPL_CapGridComp_Wrapper - type :: MAPL_MetaComp_Wrapper - type(MAPL_MetaComp), pointer :: ptr => null() - end type MAPL_MetaComp_Wrapper - include "mpif.h" character(len=*), parameter :: Iam = __FILE__ @@ -89,7 +86,7 @@ subroutine MAPL_CapGridCompCreate(cap, mapl_comm, root_set_services, cap_rc, nam character(len=*), optional, intent(in) :: final_file type(MAPL_CapGridComp_Wrapper) :: cap_wrapper - type(MAPL_MetaComp_Wrapper) :: meta_comp_wrapper + type(MAPL_MetaComp), pointer :: meta integer :: status, rc @@ -100,18 +97,22 @@ subroutine MAPL_CapGridCompCreate(cap, mapl_comm, root_set_services, cap_rc, nam allocate(cap%final_file, source=final_file) end if + cap%config = ESMF_ConfigCreate(rc=status) + _VERIFY(status) + call ESMF_ConfigLoadFile(cap%config,cap%cap_rc_file,rc=STATUS) + _VERIFY(STATUS) + allocate(cap%name, source=name) + cap%gc = ESMF_GridCompCreate(name='MAPL_CapGridComp', config=cap%config, rc=status) + _VERIFY(status) - cap%gc = ESMF_GridCompCreate(name='MAPL_CapGridComp', rc=status) + call MAPL_InternalStateCreate(cap%gc, meta, rc=status) _VERIFY(status) cap_wrapper%ptr => cap call ESMF_UserCompSetInternalState(cap%gc, internal_cap_name, cap_wrapper, status) _VERIFY(status) - allocate(meta_comp_wrapper%ptr) - call ESMF_UserCompSetInternalState(cap%gc, internal_meta_comp_name, meta_comp_wrapper, status) - _VERIFY(status) end subroutine MAPL_CapGridCompCreate @@ -166,16 +167,22 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) logical :: tend,foundPath - type (MAPL_MetaComp), pointer :: MAPLOBJ + type (MAPL_MetaComp), pointer :: maplobj + type (MAPL_MetaComp), pointer :: CHILD_MAPLOBJ procedure(), pointer :: root_set_services type(MAPL_CapGridComp), pointer :: cap + class(BaseProfiler), pointer :: t_p + class(Logger), pointer :: lgr _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) _UNUSED_DUMMY(clock) cap => get_CapGridComp_from_gc(gc) - maplobj => get_MetaComp_from_gc(gc) + call MAPL_GetObjectFromGC(gc, maplobj, rc=status) + _VERIFY(status) + + t_p => get_global_time_profiler() call ESMF_GridCompGet(gc, vm = cap%vm, rc = status) _VERIFY(status) @@ -191,23 +198,17 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) cap%AmIRoot = AmIRoot_ - ! Open the CAP's configuration from CAP.rc - !------------------------------------------ - - cap%config = ESMF_ConfigCreate(rc = status) - _VERIFY(status) - - call ESMF_ConfigLoadFile(cap%config, cap%cap_rc_file, rc = status) - _VERIFY(status) - ! CAP's MAPL MetaComp !--------------------- call MAPL_Set(MAPLOBJ, mapl_comm = cap%mapl_Comm, rc = status) _VERIFY(STATUS) - call MAPL_Set(MAPLOBJ, name = cap%name, cf = cap%config, rc = status) + ! Note the call to GetLogger must be _after_ the call to MAPL_Set(). + ! That call establishes the name of this component which is used in + ! retrieving this component's logger. + call MAPL_GetLogger(gc, lgr, rc=status) _VERIFY(status) - + ! Check if user wants to use node shared memory (default is no) !-------------------------------------------------------------- call MAPL_GetResource(MAPLOBJ, useShmem, label = 'USE_SHMEM:', default = 0, rc = status) @@ -281,11 +282,9 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) endif if (cap%lperp) then - if (AmIRoot_) then - if (cap%perpetual_year /= -999 ) print *, 'Using Perpetual Year: ', cap%perpetual_year - if (cap%perpetual_month /= -999 ) print *, 'Using Perpetual Month: ', cap%perpetual_month - if (cap%perpetual_day /= -999 ) print *, 'Using Perpetual Day: ', cap%perpetual_day - endif + if (cap%perpetual_year /= -999) call lgr%info('Using Perpetual Year: %i0', cap%perpetual_year) + if (cap%perpetual_month /= -999) call lgr%info('Using Perpetual Month: %i0', cap%perpetual_month) + if (cap%perpetual_day /= -999) call lgr%info('Using Perpetual Day: %i0', cap%perpetual_day) call ESMF_ClockGet(cap%clock, name = clockname, rc = status) clockname = trim(clockname) // '_PERPETUAL' @@ -360,6 +359,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call MAPL_TimerModeSet(timerMode, RC=status) _VERIFY(status) end if + cap%started_loop_timer=.false. enableMemUtils = ESMF_UtilStringUpperCase(enableMemUtils, rc=STATUS) _VERIFY(STATUS) @@ -402,11 +402,8 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigGetAttribute(cap%cf_root, value=RUN_DT, Label="RUN_DT:", rc=status) if (STATUS == ESMF_SUCCESS) then if (heartbeat_dt /= run_dt) then - if (AmIRoot_) then - print *, "ERROR: inconsistent values of HEARTBEAT_DT and RUN_DT" - end if - call ESMF_VMBarrier(CAP%VM) - _RETURN(ESMF_FAILURE) + call lgr%error('inconsistent values of HEARTBEAT_DT (%g0) and root RUN_DT (%g0)', heartbeat_dt, run_dt) + _FAIL('inconsistent values of HEARTBEAT_DT and RUN_DT') end if else call MAPL_ConfigSetAttribute(cap%cf_root, value=heartbeat_dt, Label="RUN_DT:", rc=status) @@ -475,6 +472,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) root_set_services => cap%root_set_services + call t_p%start('SetService') cap%root_id = MAPL_AddChild(MAPLOBJ, name = root_name, SS = root_set_services, rc = status) _VERIFY(status) @@ -498,11 +496,8 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigGetAttribute(cap%cf_ext, value=RUN_DT, Label="RUN_DT:", rc=status) if (STATUS == ESMF_SUCCESS) then if (heartbeat_dt /= run_dt) then - if (AmIRoot_) then - print *, "ERROR: inconsistent values of HEATBEAT_DT and RUN_DT", heartbeat_dt, run_dt - end if - call ESMF_VMBarrier(CAP%VM) - _RETURN(ESMF_FAILURE) + call lgr%error('inconsistent values of HEARTBEAT_DT (%g0) and ExtData RUN_DT (%g0)', heartbeat_dt, run_dt) + _FAIL('inconsistent values of HEARTBEAT_DT and RUN_DT') end if else call MAPL_ConfigSetAttribute(cap%cf_ext, value=heartbeat_dt, Label="RUN_DT:", rc=status) @@ -514,6 +509,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) cap%extdata_id = MAPL_AddChild (MAPLOBJ, name = 'EXTDATA', SS = ExtData_SetServices, rc = status) _VERIFY(status) + call t_p%stop('SetService') ! Add NX and NY from AGCM.rc to ExtData.rc as well as name of ExtData rc file call ESMF_ConfigGetAttribute(cap%cf_root, value = NX, Label="NX:", rc=status) @@ -548,14 +544,27 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) ! Initialize the Computational Hierarchy !---------------------------------------- + call t_p%start('Initialize') + call t_p%start(trim(root_name)) + call MAPL_InternalStateRetrieve(cap%gcs(cap%root_id), CHILD_MAPLOBJ, RC=status) + call CHILD_MAPLOBJ%t_profiler%start() + call CHILD_MAPLOBJ%t_profiler%start('Intialize') call ESMF_GridCompInitialize(cap%gcs(cap%root_id), importState = cap%child_imports(cap%root_id), & exportState = cap%child_exports(cap%root_id), clock = cap%clock, userRC = status) _VERIFY(status) + call CHILD_MAPLOBJ%t_profiler%stop('Intialize') + call CHILD_MAPLOBJ%t_profiler%stop() + call t_p%stop(trim(root_name)) + call t_p%start('HIST') call cap%initialize_history(rc=status) _VERIFY(status) + call t_p%stop('HIST') + + call t_p%start('EXTDATA') call cap%initialize_extdata(rc=status) _VERIFY(status) + call t_p%stop('EXTDATA') ! Finally check is this is a regular replay ! If so stuff gc and input state for ExtData in GCM internal state @@ -572,7 +581,10 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) ExtData_internal_state%gc = CAP%GCS(cap%extdata_id) ExtData_internal_state%expState = CAP%CHILD_EXPORTS(cap%extdata_id) end if + call t_p%stop('Initialize') end if + + _RETURN(ESMF_SUCCESS) end subroutine initialize_gc @@ -582,12 +594,12 @@ subroutine initialize_history(cap, rc) integer, optional, intent(out) :: rc integer :: status type(HISTORY_ExchangeListWrap) :: lswrap - integer*8, pointer :: LSADDR(:) => null() + integer*8, pointer :: LSADDR(:) => null() + type (MAPL_MetaComp), pointer :: CHILD_MAPLOBJ if (present(rc)) rc = ESMF_SUCCESS ! All the EXPORTS of the Hierachy are made IMPORTS of History !------------------------------------------------------------ - call ESMF_StateAdd(cap%child_imports(cap%history_id), [cap%child_exports(cap%root_id)], rc = status) _VERIFY(STATUS) @@ -603,10 +615,17 @@ subroutine initialize_history(cap, rc) ! Initialize the History !------------------------ + call MAPL_InternalStateRetrieve(cap%gcs(cap%history_id), CHILD_MAPLOBJ, RC=status) + call CHILD_MAPLOBJ%t_profiler%start() + call CHILD_MAPLOBJ%t_profiler%start('Intialize') + call ESMF_GridCompInitialize (CAP%GCS(cap%history_id), importState=CAP%CHILD_IMPORTS(cap%history_id), & exportState=CAP%CHILD_EXPORTS(cap%history_id), clock=CAP%CLOCK_HIST, userRC=STATUS ) _VERIFY(STATUS) + call CHILD_MAPLOBJ%t_profiler%stop('Intialize') + call CHILD_MAPLOBJ%t_profiler%stop() + _RETURN(ESMF_SUCCESS) end subroutine initialize_history @@ -624,6 +643,7 @@ subroutine initialize_extdata(cap , rc) integer :: i type(ESMF_State) :: state, root_imports, component_state character(len=:), allocatable :: component_name, field_name + type (MAPL_MetaComp), pointer :: CHILD_MAPLOBJ ! Prepare EXPORTS for ExtData ! --------------------------- @@ -694,11 +714,19 @@ subroutine initialize_extdata(cap , rc) ! Initialize the ExtData !------------------------ + + call MAPL_InternalStateRetrieve(cap%gcs(cap%extdata_id), CHILD_MAPLOBJ, RC=status) + call CHILD_MAPLOBJ%t_profiler%start() + call CHILD_MAPLOBJ%t_profiler%start('Intialize') + call ESMF_GridCompInitialize (cap%gcs(cap%extdata_id), importState = cap%child_imports(cap%extdata_id), & exportState = cap%child_exports(cap%extdata_id), & clock = cap%clock, userRc = status) _VERIFY(status) + call CHILD_MAPLOBJ%t_profiler%stop('Intialize') + call CHILD_MAPLOBJ%t_profiler%stop() + _RETURN(ESMF_SUCCESS) end subroutine initialize_extdata @@ -713,13 +741,20 @@ subroutine run_gc(gc, import, export, clock, rc) integer, intent(out) :: RC ! Error code: integer :: status + class (BaseProfiler), pointer :: t_p _UNUSED_DUMMY(import) _UNUSED_DUMMY(export) _UNUSED_DUMMY(clock) + t_p => get_global_time_profiler() + call t_p%start('Run') + call run_MAPL_GridComp(gc, rc=status) _VERIFY(status) + + call t_p%stop('Run') + _RETURN(ESMF_SUCCESS) end subroutine run_gc @@ -734,14 +769,19 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) integer :: status type(MAPL_CapGridComp), pointer :: cap - type(MAPL_MetaComp), pointer :: MAPLOBJ + type(MAPL_MetaComp), pointer :: maplobj + class (BaseProfiler), pointer :: t_p _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) _UNUSED_DUMMY(clock) cap => get_CapGridComp_from_gc(gc) - MAPLOBJ => get_MetaComp_from_gc(gc) + call MAPL_GetObjectFromGC(gc, maplobj, rc=status) + _VERIFY(status) + + t_p => get_global_time_profiler() + call t_p%start('Finalize') if (.not. cap%printspec > 0) then @@ -785,6 +825,9 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) end if end if end if + + call t_p%stop('Finalize') + _RETURN(ESMF_SUCCESS) end subroutine finalize_gc @@ -843,7 +886,6 @@ subroutine run(this, rc) end subroutine run - subroutine finalize(this, rc) class(MAPL_CapGridComp), intent(inout) :: this integer, optional, intent(out) :: rc @@ -855,7 +897,6 @@ subroutine finalize(this, rc) _RETURN(ESMF_SUCCESS) end subroutine finalize - function get_model_duration(this, rc) result (duration) class (MAPL_CapGridComp) :: this integer, optional, intent(out) :: rc @@ -906,15 +947,6 @@ function get_CapGridComp_from_gc(gc) result(cap) end function get_CapGridComp_from_gc - function get_MetaComp_from_gc(gc) result(meta_comp) - type(ESMF_GridComp), intent(inout) :: gc - type(MAPL_MetaComp), pointer :: meta_comp - type(MAPL_MetaComp_Wrapper) :: meta_comp_wrapper - integer :: rc - call ESMF_UserCompGetInternalState(gc, internal_meta_comp_name, meta_comp_wrapper, rc) - meta_comp => meta_comp_wrapper%ptr - end function get_MetaComp_from_gc - function get_vec_from_config(config, key) result(vec) type(ESMF_Config), intent(inout) :: config @@ -976,7 +1008,8 @@ subroutine run_MAPL_GridComp(gc, rc) procedure(), pointer :: root_set_services cap => get_CapGridComp_from_gc(gc) - MAPLOBJ => get_MetaComp_from_gc(gc) + call MAPL_GetObjectFromGC(gc, maplobj, rc=status) + _VERIFY(status) if (.not. cap%printspec > 0) then @@ -985,6 +1018,7 @@ subroutine run_MAPL_GridComp(gc, rc) call ESMF_VMBarrier(cap%vm,rc=status) _VERIFY(status) cap%loop_start_timer = MPI_WTime(status) + cap%started_loop_timer = .true. TIME_LOOP: do n = 1, cap%nsteps call MAPL_MemUtilsWrite(cap%vm, 'MAPL_Cap:TimeLoop', rc = status) @@ -999,6 +1033,16 @@ subroutine run_MAPL_GridComp(gc, rc) call cap%step(status) _VERIFY(status) + ! Reset loop average timer to get a better + ! estimate of true run time left by ignoring + ! initialization costs in the averageing. + !------------------------------------------- + if (n == 1) then + call ESMF_VMBarrier(cap%vm,rc=status) + _VERIFY(status) + cap%loop_start_timer = MPI_WTime(status) + endif + enddo TIME_LOOP ! end of time loop end if @@ -1019,7 +1063,8 @@ subroutine step(this, rc) real(kind=REAL64) :: LOOP_THROUGHPUT=0.0_REAL64 real(kind=REAL64) :: INST_THROUGHPUT=0.0_REAL64 real(kind=REAL64) :: RUN_THROUGHPUT=0.0_REAL64 - real :: mem_total, mem_commit, mem_percent + real :: mem_total, mem_commit, mem_committed_percent + real :: mem_used, mem_used_percent type(ESMF_Time) :: currTime type(ESMF_TimeInterval) :: delt @@ -1028,6 +1073,10 @@ subroutine step(this, rc) call ESMF_GridCompGet(this%gc, vm = this%vm) + if (.not.this%started_loop_timer) then + this%loop_start_timer = MPI_WTime(status) + this%started_loop_timer=.true. + end if start_timer = MPI_Wtime(status) ! Run the ExtData Component ! -------------------------- @@ -1118,14 +1167,19 @@ subroutine step(this, rc) SEC_R = FLOOR(TIME_REMAINING - 3600.0*HRS_R - 60.0*MIN_R) ! Reset Inst timer START_TIMER=END_TIMER + ! Get percent of used memory + call MAPL_MemUsed ( mem_total, mem_used, mem_used_percent, RC=STATUS ) + _VERIFY(STATUS) ! Get percent of committed memory - call MAPL_MemCommited ( mem_total, mem_commit, mem_percent, RC=STATUS ) + call MAPL_MemCommited ( mem_total, mem_commit, mem_committed_percent, RC=STATUS ) _VERIFY(STATUS) if( mapl_am_I_Root(this%vm) ) write(6,1000) AGCM_YY,AGCM_MM,AGCM_DD,AGCM_H,AGCM_M,AGCM_S,& - LOOP_THROUGHPUT,INST_THROUGHPUT,RUN_THROUGHPUT,HRS_R,MIN_R,SEC_R,mem_percent + 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]: ',f6.1,1x,f6.1,1x,f6.1,2x,'TimeRemaining(Est) ',i3.3,':'i2.2,':',i2.2,2x,f5.1,'% Memory Committed') + 2x,'Throughput(days/day)[Avg Tot Run]: ',f6.1,1x,f6.1,1x,f6.1,2x,'TimeRemaining(Est) ',i3.3,':'i2.2,':',i2.2,2x, & + f5.1,'% : ',f5.1,'% Mem Comm:Used') _RETURN(ESMF_SUCCESS) end subroutine step diff --git a/MAPL_Base/MAPL_CapOptions.F90 b/MAPL_Base/MAPL_CapOptions.F90 index 0eb39dfe341d..731b51141db5 100644 --- a/MAPL_Base/MAPL_CapOptions.F90 +++ b/MAPL_Base/MAPL_CapOptions.F90 @@ -30,6 +30,8 @@ module MAPL_CapOptionsMod ! ensemble options integer :: n_members = 1 character(:), allocatable :: ensemble_subdir_prefix + ! logging options + character(:), allocatable :: logging_config end type MAPL_CapOptions @@ -47,7 +49,6 @@ function new_CapOptions(unusable, cap_rc_file, egress_file, ensemble_subdir_pref character(*), optional, intent(in) :: ensemble_subdir_prefix integer, optional, intent(out) :: rc - integer :: status _UNUSED_DUMMY(unusable) diff --git a/MAPL_Base/MAPL_Comms.F90 b/MAPL_Base/MAPL_Comms.F90 index b057a21b1c5c..5f861e65c48a 100644 --- a/MAPL_Base/MAPL_Comms.F90 +++ b/MAPL_Base/MAPL_Comms.F90 @@ -1,5 +1,4 @@ -! $Id$ #include "MAPL_ErrLog.h" @@ -291,7 +290,7 @@ subroutine MAPL_CreateRequest(grid, Root, request, tag, RequestType, & ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_CreateRequest' + type (ESMF_VM) :: VM type (ESMF_DistGrid) :: distGrid @@ -479,7 +478,7 @@ subroutine MAPL_ArrayIGather_R4_2(local_array, request, rc) ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_ArrayIGather2d' + integer :: i1, in, j1, jn @@ -517,7 +516,7 @@ subroutine MAPL_ArrayIScatter_R4_2(global_array, request, hw, rc) ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_ArrayIScatter2d' + integer :: i1,in,j1,jn @@ -586,7 +585,7 @@ subroutine MAPL_CollectiveWait(request, DstArray, rc) integer, optional, intent( OUT) :: rc integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_CollectiveWait' + integer :: i,j,k,n integer :: count @@ -699,7 +698,7 @@ subroutine MAPL_CollectiveGather3D(Grid, LocArray, GlobArray, & !------- integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_CollectiveGather3D' + type (MAPL_CommRequest) :: reqs(size(LocArray,3)) integer :: root(size(LocArray,3)) @@ -788,7 +787,7 @@ subroutine MAPL_CollectiveScatter3D(Grid, GlobArray, LocArray, hw, rc) !------- integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_CollectiveScatter3D' + type (MAPL_CommRequest) :: reqs(size(LocArray,3)) integer :: root(size(LocArray,3)) @@ -863,7 +862,7 @@ subroutine MAPL_RoundRobinPEList(List,nNodes,Root,UseFirstRank,FirstRank,RC) integer, optional, intent( OUT) :: RC integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_RoundRobinPEList' + integer, allocatable :: filled(:),nPerNode(:) integer :: i,n,nlist,locRoot logical :: gotFirstRank,lUseFirstRank @@ -963,7 +962,7 @@ subroutine MAPL_CommsBcast_STRING_0( layout, data, N, ROOT, RC) integer, intent(in ) :: ROOT integer , intent( out), optional :: RC - character(len=ESMF_MAXSTR), parameter :: IAM='MAPL_Bcast' + integer :: status type(ESMF_VM) :: vm @@ -986,7 +985,7 @@ subroutine MAPL_CommsBcastVM_STRING_0( vm, data, N, ROOT,RC) integer, intent(in ) :: ROOT integer , intent( out), optional :: RC - character(len=ESMF_MAXSTR), parameter :: IAM='MAPL_BcastVM' + character(len=N) :: tmpString integer :: slen integer :: status @@ -1026,7 +1025,7 @@ subroutine MAPL_BcastShared_1DR4(VM, Data, N, Root, RootOnly, rc) integer :: status - character(len=ESMF_MAXSTR), parameter :: IAM='MAPL_BcastShared' + if(.not.MAPL_ShmInitialized) then @@ -1058,7 +1057,7 @@ subroutine MAPL_BcastShared_2DR4(VM, Data, N, Root, RootOnly, rc) integer :: status - character(len=ESMF_MAXSTR), parameter :: IAM='MAPL_BcastShared' + if(.not.MAPL_ShmInitialized) then diff --git a/MAPL_Base/MAPL_Constants.F90 b/MAPL_Base/MAPL_Constants.F90 index c796a963c015..fb70c5c691b2 100644 --- a/MAPL_Base/MAPL_Constants.F90 +++ b/MAPL_Base/MAPL_Constants.F90 @@ -1,6 +1,5 @@ module MAPL_ConstantsMod -! $Id$ use, intrinsic :: iso_fortran_env, only: REAL64, REAL32 implicit none private diff --git a/MAPL_Base/MAPL_CubedSphereGridFactory.F90 b/MAPL_Base/MAPL_CubedSphereGridFactory.F90 index 16fd8ef93f3f..fb69ccba98ee 100644 --- a/MAPL_Base/MAPL_CubedSphereGridFactory.F90 +++ b/MAPL_Base/MAPL_CubedSphereGridFactory.F90 @@ -60,7 +60,9 @@ module MAPL_CubedSphereGridFactoryMod ! rectangle decomposition integer, allocatable :: jms_2d(:,:) ! stretching parameters - real :: stretch_factor, target_lon, target_lat + real :: stretch_factor = UNDEFINED_REAL + real :: target_lon = UNDEFINED_REAL + real :: target_lat = UNDEFINED_REAL logical :: stretched_cube = .false. ! For halo @@ -88,6 +90,9 @@ module MAPL_CubedSphereGridFactoryMod procedure :: append_metadata procedure :: get_grid_vars procedure :: append_variable_metadata + procedure :: generate_file_bounds + procedure :: generate_file_reference2D + procedure :: generate_file_reference3D procedure :: get_fake_longitudes procedure :: get_fake_latitudes end type CubedSphereGridFactory @@ -173,6 +178,8 @@ function make_new_grid(this, unusable, rc) result(grid) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'make_grid' + _UNUSED_DUMMY(unusable) + grid = this%create_basic_grid(rc=status) _VERIFY(status) @@ -195,6 +202,8 @@ function create_basic_grid(this, unusable, rc) result(grid) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'create_basic_grid' + _UNUSED_DUMMY(unusable) + if (this%grid_type <=3) then nTile=6 else @@ -293,6 +302,8 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, rc) character(len=*), parameter :: Iam= MOD_NAME // 'initialize_from_file_metadata()' integer :: status + logical :: hasLev,hasLevel + character(:), allocatable :: lev_name associate(im => this%im_world) im = file_metadata%get_dimension('Xdim',rc=status) @@ -300,6 +311,23 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, rc) end associate call this%make_arbitrary_decomposition(this%nx, this%ny, reduceFactor=6, rc=status) _VERIFY(status) + + hasLev=.false. + hasLevel=.false. + lev_name = 'lev' + hasLev = file_metadata%has_dimension(lev_name) + if (hasLev) then + this%lm = file_metadata%get_dimension(lev_name,rc=status) + _VERIFY(status) + else + lev_name = 'levels' + hasLevel = file_metadata%has_dimension(lev_name) + if (hasLevel) then + this%lm = file_metadata%get_dimension(lev_name,rc=status) + _VERIFY(status) + end if + end if + allocate(this%ims(0:this%nx-1)) allocate(this%jms(0:this%ny-1)) call MAPL_DecomposeDim(this%im_world, this%ims, this%nx, min_DE_extent=2) @@ -555,6 +583,7 @@ subroutine check_and_fill_consistency(this, unusable, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'check_and_fill_consistency' + _UNUSED_DUMMY(unusable) if (.not. allocated(this%grid_name)) then this%grid_name = GRID_NAME_DEFAULT @@ -736,9 +765,14 @@ subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'CubedSphereGridFactory_initialize_from_esmf_distGrid' + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(dist_grid) + _UNUSED_DUMMY(lon_array) + _UNUSED_DUMMY(lat_array) + _UNUSED_DUMMY(unusable) + ! not implemented _ASSERT(.false.) @@ -759,6 +793,8 @@ subroutine halo(this, array, unusable, halo_width, rc) real, pointer :: ptr(:,:) integer :: useableHalo_width + _UNUSED_DUMMY(unusable) + if (.not. this%halo_initialized) then call this%halo_init(halo_width = halo_width) this%halo_initialized = .true. @@ -949,6 +985,7 @@ function get_grid_vars(this) result(vars) class (CubedSphereGridFactory), intent(inout) :: this character(len=:), allocatable :: vars + _UNUSED_DUMMY(this) vars = 'Xdim,Ydim,nf' @@ -957,6 +994,7 @@ end function get_grid_vars subroutine append_variable_metadata(this,var) class (CubedSphereGridFactory), intent(inout) :: this type(Variable), intent(inout) :: var + _UNUSED_DUMMY(this) call var%add_attribute('coordinates','lons lats') call var%add_attribute('grid_mapping','cubed_sphere') @@ -990,6 +1028,8 @@ function get_fake_longitudes(this, unusable, rc) result(longitudes) character(len=*), parameter :: Iam = MOD_NAME // 'get_fake_longitudes()' + _UNUSED_DUMMY(unusable) + grid = this%make_grid() call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & @@ -1007,7 +1047,7 @@ function get_fake_longitudes(this, unusable, rc) result(longitudes) j_mid = 1 + this%im_world/2 - tile = 1 + pet/(npes/this%nTiles) + tile = 1 + (j_1-1)/this%im_world if (tile == 1 .and. (j_1 <= j_mid) .and. (j_mid <= j_n)) then allocate(piece(i_1:i_n)) piece(:) = centers(:,j_mid-(j_1-1)) @@ -1059,6 +1099,8 @@ function get_fake_latitudes(this, unusable, rc) result(latitudes) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'get_fake_latitudes()' + + _UNUSED_DUMMY(unusable) grid = this%make_grid() @@ -1077,7 +1119,7 @@ function get_fake_latitudes(this, unusable, rc) result(latitudes) j_mid = 1 + this%im_world/2 - tile = 1 + pet/(npes/this%nTiles) + tile = 1 + (j_1-1)/this%im_world if (tile == 1 .and. (i_1 <= j_mid) .and. (j_mid <= i_n)) then allocate(piece(j_1:j_n)) piece(:) = centers(j_mid-(i_1-1),:) @@ -1105,5 +1147,54 @@ function get_fake_latitudes(this, unusable, rc) result(latitudes) latitudes = latitudes * MAPL_RADIANS_TO_DEGREES end function get_fake_latitudes + + subroutine generate_file_bounds(this,grid,local_start,global_start,global_count,rc) + use MAPL_BaseMod + class(CubedSphereGridFactory), intent(inout) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, allocatable, intent(inout) :: local_start(:) + integer, allocatable, intent(inout) :: global_start(:) + integer, allocatable, intent(inout) :: global_count(:) + integer, optional, intent(out) :: rc + + integer :: status + integer :: global_dim(3),i1,j1,in,jn,tile + character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' + _UNUSED_DUMMY(this) + + call MAPL_GridGet(grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_GridGetInterior(grid,i1,in,j1,jn) + tile = 1 + (j1-1)/global_dim(1) + allocate(local_start,source=[i1,j1-(tile-1)*global_dim(1),tile]) + allocate(global_start,source=[1,1,1]) + allocate(global_count,source=[global_dim(1),global_dim(1),6]) + + _RETURN(_SUCCESS) + + end subroutine generate_file_bounds + + function generate_file_reference2D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(CubedSphereGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference2D + + function generate_file_reference3D(this,fpointer) result(ref) + use pFIO + use, intrinsic :: ISO_C_BINDING + type(ArrayReference) :: ref + class(CubedSphereGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:,:) + type(c_ptr) :: cptr + real, pointer :: ptr_ref(:,:,:,:,:) + _UNUSED_DUMMY(this) + cptr = c_loc(fpointer) + call C_F_pointer(cptr,ptr_ref,[size(fpointer,1),size(fpointer,2),1,size(fpointer,3),1]) + ref = ArrayReference(ptr_ref) + end function generate_file_reference3D end module MAPL_CubedSphereGridFactoryMod diff --git a/MAPL_Base/MAPL_DirPath.F90 b/MAPL_Base/MAPL_DirPath.F90 index ce188d69ea4c..3d55a54bd281 100644 --- a/MAPL_Base/MAPL_DirPath.F90 +++ b/MAPL_Base/MAPL_DirPath.F90 @@ -1,3 +1,5 @@ +#include "unused_dummy.H" + module MAPL_DirPathMod use MAPL_KeywordEnforcerMod use pFIO @@ -34,6 +36,8 @@ function find(this, file, unusable, rc) result(full_name) character(len=:), pointer :: dir logical :: exist + _UNUSED_DUMMY(unusable) + iter = this%begin() do while (iter /= this%end()) dir => iter%get() @@ -63,6 +67,8 @@ subroutine append(this, directory, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(unusable) + call this%push_back(directory) if (present(rc)) then diff --git a/MAPL_Base/MAPL_ErrLog.h b/MAPL_Base/MAPL_ErrLog.h index 53a5ec4930c9..342163792afe 100644 --- a/MAPL_Base/MAPL_ErrLog.h +++ b/MAPL_Base/MAPL_ErrLog.h @@ -1,5 +1,4 @@ -! $Id$ ! The error logging may eventually evolve into a module based ! on the ESMF logger. For now these macros provide simple diff --git a/MAPL_Base/MAPL_ErrLogMain.h b/MAPL_Base/MAPL_ErrLogMain.h index 0c5008b6e68f..6c9bcf9d273f 100644 --- a/MAPL_Base/MAPL_ErrLogMain.h +++ b/MAPL_Base/MAPL_ErrLogMain.h @@ -1,5 +1,4 @@ -! $Id$ ! The error logging may eventually evolve into a module based ! on the ESMF logger. For now these macros provide simple diff --git a/MAPL_Base/MAPL_EsmfRegridder.F90 b/MAPL_Base/MAPL_EsmfRegridder.F90 index dea26314b5da..46a4c93c88d7 100644 --- a/MAPL_Base/MAPL_EsmfRegridder.F90 +++ b/MAPL_Base/MAPL_EsmfRegridder.F90 @@ -71,6 +71,8 @@ function new_EsmfRegridder() result(regridder) use MAPL_BaseMod type (EsmfRegridder) :: regridder + _UNUSED_DUMMY(regridder) + ! Nothing to do here end function new_EsmfRegridder diff --git a/MAPL_Base/MAPL_EtaHybridVerticalCoordinate.F90 b/MAPL_Base/MAPL_EtaHybridVerticalCoordinate.F90 new file mode 100644 index 000000000000..b80fb8cf7366 --- /dev/null +++ b/MAPL_Base/MAPL_EtaHybridVerticalCoordinate.F90 @@ -0,0 +1,333 @@ +#include "MAPL_Generic.h" + +module MAPL_EtaHybridVerticalCoordinateMod + use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64, REAL32 + use ESMF + use MAPL_ErrorHandlingMod + use MAPL_KeywordEnforcerMod + implicit none + private + + public :: EtaHybridVerticalCoordinate + public :: get_eta + + type :: EtaHybridVerticalCoordinate + private + real(kind=REAL64), allocatable :: ak(:) + real(kind=REAL64), allocatable :: bk(:) + integer :: num_levels = 0 + real(kind=REAL64) :: ref_pressure + contains + procedure :: get_eta_r8 + procedure :: get_eta_r4 + procedure :: get_pressure_levels_r8 + procedure :: get_pressure_levels_r4 + procedure :: get_pressures_r8_3d + procedure :: get_pressures_r4_3d + generic :: get_eta =>get_eta_r8, get_eta_r4 + generic :: get_pressure_levels=>get_pressure_levels_r8, get_pressure_levels_r4 + generic :: get_pressures =>get_pressures_r8_3d,get_pressures_r4_3d + end type EtaHybridVerticalCoordinate + + interface EtaHybridVerticalCoordinate + module procedure new_EtaHybridVerticalCoordinate_by_ak_bk + module procedure new_EtaHybridVerticalCoordinate_by_cfg + module procedure new_EtaHybridVerticalCoordinate_by_file + end interface + + interface get_eta + module procedure get_eta_onestep_r4 + module procedure get_eta_onestep_r8 + end interface + + real(kind=REAL64), parameter :: DEFAULT_REFERENCE_PRESSURE = 98400.d0 ! (Pa) default reference pressure + +contains + + function new_EtaHybridVerticalCoordinate_by_ak_bk(ak, bk, unused, ref_pressure, rc) result(grid) + type (EtaHybridVerticalCoordinate) :: grid + real(kind=REAL64), intent(in) :: ak(:) + real(kind=REAL64), intent(in) :: bk(:) + class(KeywordEnforcer), optional, intent(in) :: unused + real(kind=REAL64),optional, intent(in) :: ref_pressure + integer, optional, intent(inout) :: rc + + _ASSERT(size(ak) >= 2, 'size of ak should be >=2') + _ASSERT(size(ak) == size(bk), ' size of ak should be the same as that of bk') + + grid%ak = ak + grid%bk = bk + grid%num_levels = size(ak) - 1 + + if (present(ref_pressure)) then + grid%ref_pressure = ref_pressure + else + grid%ref_pressure = DEFAULT_REFERENCE_PRESSURE + end if + + end function new_EtaHybridVerticalCoordinate_by_ak_bk + + function new_EtaHybridVerticalCoordinate_by_cfg(config, unused, rc) result(grid) + type (EtaHybridVerticalCoordinate) :: grid + type (ESMF_Config) :: config + class (KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(inout) :: rc + real(kind=REAL64), allocatable :: ak(:) + real(kind=REAL64), allocatable :: bk(:) + integer :: status + integer :: k, num_levels + real(kind=REAL64) :: ptop, pint, ref_pressure + character(len=32) :: data_label + + call ESMF_ConfigGetAttribute(config, num_levels,label='NUM_LEVELS:', __RC__ ) + call ESMF_ConfigGetAttribute(config, ref_pressure,label='REF_PRESSURE:', & + default = DEFAULT_REFERENCE_PRESSURE, __RC__ ) + + data_label = "ak-bk:" + + allocate(ak(num_levels+1), bk(num_levels+1)) + + call ESMF_ConfigFindLabel(config, trim(data_label), __RC__ ) + + ! get ak and bk + do k = 1, num_levels+1 + call ESMF_ConfigNextLine(config, __RC__ ) + call ESMF_ConfigGetAttribute(config, ak(k), __RC__ ) + call ESMF_ConfigGetAttribute(config, bk(k), __RC__ ) + enddo + + grid = EtaHybridVerticalCoordinate(ak, bk, ref_pressure=ref_pressure) + + deallocate(ak, bk) + end function new_EtaHybridVerticalCoordinate_by_cfg + + function new_EtaHybridVerticalCoordinate_by_file(filename, unused, rc) result(grid) + type (EtaHybridVerticalCoordinate) :: grid + character(len=*), intent(in) :: filename + class (KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(inout) :: rc + type (ESMF_Config) :: config + integer :: status + + call ESMF_ConfigLoadFile (config, filename, __RC__) + + grid = EtaHybridVerticalCoordinate(config) + + end function new_EtaHybridVerticalCoordinate_by_file + + subroutine get_eta_r8(this, ptop, pint, ak, bk, unused,rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL64), intent(out) :: ak(:) + real(kind=REAL64), intent(out) :: bk(:) + real(kind=REAL64), intent(out) :: ptop ! model top (Pa) + real(kind=REAL64), intent(out) :: pint ! transition to p (Pa) + class(KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(out) :: rc + integer :: num_levels, k, ks + + _ASSERT(this%num_levels == size(ak) - 1 ,"size vertical grid should be consistent") + + ak = this%ak + bk = this%bk + do k = 1, num_levels+1 + if (num_levels == 1) then + ks = 1 + exit + endif + + if ( bk(k) > 0.0d0) then + ks = k -2 + exit + endif + enddo + ptop = this%ak(1) + pint = this%ak(ks+1) + + _RETURN(_SUCCESS) + + end subroutine get_eta_r8 + + subroutine get_eta_r4(this, ptop, pint, ak, bk, unused,rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL32), intent(out) :: ak(:) + real(kind=REAL32), intent(out) :: bk(:) + real(kind=REAL32), intent(out) :: ptop ! model top (Pa) + real(kind=REAL32), intent(out) :: pint ! transition to p (Pa) + class(KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(out) :: rc + + real(kind=REAL64), allocatable :: ak8(:) + real(kind=REAL64), allocatable :: bk8(:) + real(kind=REAL64) :: ptop8 ! model top (Pa) + real(kind=REAL64) :: pint8 ! transition to p (Pa) + integer :: num_levels + + num_levels = this%num_levels + allocate(ak8(num_levels+1)) + allocate(bk8(num_levels+1)) + + call this%get_eta(ptop8, pint8, ak8, bk8) + + ak = real(ak8, kind=REAL32) + bk = real(bk8, kind=REAL32) + + ptop = ptop8 + pint = pint8 + + deallocate(ak8,bk8) + + _RETURN(_SUCCESS) + end subroutine get_eta_r4 + + subroutine get_eta_onestep_r4(filename, ptop, pint, ak, bk, unused, rc) + character(len=*), intent(in) :: filename + real(kind=REAL32), intent(out) :: ak(:) + real(kind=REAL32), intent(out) :: bk(:) + real(kind=REAL32), intent(out) :: ptop ! model top (Pa) + real(kind=REAL32), intent(out) :: pint ! transition to p (Pa) + class(KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(out) :: rc + integer :: status + type (EtaHybridVerticalCoordinate) :: vgrid + + vgrid = EtaHybridVerticalCoordinate(filename) + call vgrid%get_eta(ptop, pint, ak, bk, __RC__ ) + + end subroutine get_eta_onestep_r4 + + subroutine get_eta_onestep_r8(filename, ptop, pint, ak, bk, unused, rc) + character(len=*), intent(in) :: filename + real(kind=REAL64), intent(out) :: ak(:) + real(kind=REAL64), intent(out) :: bk(:) + real(kind=REAL64), intent(out) :: ptop ! model top (Pa) + real(kind=REAL64), intent(out) :: pint ! transition to p (Pa) + class(KeywordEnforcer), optional, intent(in) :: unused + integer, optional, intent(out) :: rc + integer :: status + type (EtaHybridVerticalCoordinate) :: vgrid + + vgrid = EtaHybridVerticalCoordinate(filename) + call vgrid%get_eta(ptop, pint, ak, bk, __RC__ ) + + end subroutine get_eta_onestep_r8 + + subroutine get_pressure_levels_r8(this, pressure_levels, unused, reference_pressure, rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL64), intent(out) :: pressure_levels(:) + class(KeywordEnforcer), optional, intent(in) :: unused + real(kind=REAL64), optional, intent(in) :: reference_pressure + integer, optional, intent(out) :: rc + real(kind=REAL64) :: p0 + integer :: k, num_levels + + num_levels = this%num_levels + _ASSERT(size(pressure_levels) == num_levels, 'incorrect array size for pressure_levels dummy argument') + + if (present(reference_pressure)) then + p0 = reference_pressure + else + p0 = this%ref_pressure + end if + + pressure_levels(1) = this%ak(1) + 0.50d0 * dpref_(1,p0) + + do k = 2, num_levels + pressure_levels(k) = pressure_levels(k-1) + 0.5d0 * (dpref_(k-1, p0) + dpref_(k,p0)) + end do + + Pressure_levels = pressure_levels/100.0d0 + + contains + real(kind=REAL64) function dpref_ (k,pbot) + integer k + real(kind=REAL64) pbot + dpref_ = ( this%ak(k+1) - this%ak(k) ) + & + ( this%bk(k+1) - this%bk(k) ) * pbot + end function dpref_ + + end subroutine get_pressure_levels_r8 + + subroutine get_pressure_levels_r4(this, pressure_levels, unused, reference_pressure, rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL32), intent(out) :: pressure_levels(:) + class(KeywordEnforcer), optional, intent(in) :: unused + real(kind=REAL32), optional, intent(in) :: reference_pressure + integer, optional, intent(out) :: rc + real(kind=REAL64) :: p0 + integer :: k, num_levels + real(kind=REAL64), allocatable :: plevels(:) + + num_levels = this%num_levels + _ASSERT(size(pressure_levels) == num_levels, 'incorrect array size for pressure_levels dummy argument') + + if (present(reference_pressure)) then + p0 = reference_pressure + else + p0 = this%ref_pressure + end if + + allocate(plevels(num_levels)) + + call this%get_pressure_levels(plevels, reference_pressure=p0) + + pressure_levels = real(plevels,kind=REAL32) + + deallocate(plevels) + + end subroutine get_pressure_levels_r4 + + subroutine get_pressures_r8_3d(this, pressures, surface_pressure, unused, rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL64), intent(out) :: pressures(:,:,:) + class(KeywordEnforcer), optional, intent(in) :: unused + real(kind=REAL64), optional, intent(in) :: surface_pressure(:,:) + integer, optional, intent(out) :: rc + integer :: i, j, k, isize, jsize, ksize + real(kind=REAL64), allocatable :: levels(:) + + isize = size(pressures,1) + jsize = size(pressures,2) + ksize = size(pressures,3) + _ASSERT(this%num_levels == ksize, "pressure levels should match") + allocate(levels(ksize)) + call this%get_pressure_levels(levels(:), reference_pressure = 0._REAL64) + + do k = 1, ksize + do j = 1, jsize + do i = 1, isize + pressures(i,j,k) = surface_pressure(i,j) + levels(k) + enddo + enddo + enddo + deallocate(levels) + + end subroutine get_pressures_r8_3d + + subroutine get_pressures_r4_3d(this, pressures, surface_pressure, unused, rc) + class(EtaHybridVerticalCoordinate), intent(in) :: this + real(kind=REAL32), intent(out) :: pressures(:,:,:) + class(KeywordEnforcer), optional, intent(in) :: unused + real(kind=REAL32), optional, intent(in) :: surface_pressure(:,:) + integer, optional, intent(out) :: rc + integer :: i, j, k, isize, jsize, ksize + real(kind=REAL32), allocatable :: levels(:) + + isize = size(pressures,1) + jsize = size(pressures,2) + ksize = size(pressures,3) + _ASSERT(this%num_levels == ksize, "pressure levels should match") + allocate(levels(ksize)) + call this%get_pressure_levels(levels(:), reference_pressure = 0._REAL32) + + do k = 1, ksize + do j = 1, jsize + do i = 1, isize + pressures(i,j,k) = surface_pressure(i,j) + levels(k) + enddo + enddo + enddo + deallocate(levels) + + end subroutine get_pressures_r4_3d + +end module MAPL_EtaHybridVerticalCoordinateMod diff --git a/MAPL_Base/MAPL_ExtDataGridCompMod.F90 b/MAPL_Base/MAPL_ExtDataGridCompMod.F90 index 260840a7c906..c21d874e4e6f 100644 --- a/MAPL_Base/MAPL_ExtDataGridCompMod.F90 +++ b/MAPL_Base/MAPL_ExtDataGridCompMod.F90 @@ -33,7 +33,7 @@ MODULE MAPL_ExtDataGridCompMod use ESMF_CFIOUtilMod use MAPL_CFIOMod use MAPL_NewArthParserMod - use MAPL_ConstantsMod, only: MAPL_PI,MAPL_PI_R8 + use MAPL_ConstantsMod, only: MAPL_PI,MAPL_PI_R8,MAPL_RADIANS_TO_DEGREES use MAPL_IOMod, only: MAPL_NCIOParseTimeUnits use MAPL_regridderSpecMod use, intrinsic :: iso_fortran_env, only: REAL64 @@ -414,7 +414,6 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) logical, allocatable :: DerivedVarNeeded(:) logical, allocatable :: LocalVarNeeded(:) - type(ESMF_CFIO), pointer :: cfio type(FileMetadataUtils), pointer :: metadata integer :: counter real, pointer :: ptr2d(:,:) => null() @@ -472,6 +471,8 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) end if if (.not.self%active) then + call MAPL_TimerOff(MAPLSTATE,"Initialize") + call MAPL_TimerOff(MAPLSTATE,"TOTAL") _RETURN(ESMF_SUCCESS) end if @@ -1293,12 +1294,9 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_Time) :: time, time0 type(MAPL_MetaComp), pointer :: MAPLSTATE - real, pointer, dimension(:,:) :: var2d_prev, var2d_next - real, pointer, dimension(:,:,:) :: var3d_prev, var3d_next logical :: doUpdate_ - integer :: fieldCount, fieldRank + integer :: fieldCount character(len=ESMF_MAXSTR), ALLOCATABLE :: NAMES (:) - type(ESMF_Field) :: field1, field2 character(len=ESMF_MAXPATHLEN) :: file_processed, file_processed1, file_processed2 logical :: NotSingle logical :: updateL, updateR, swap @@ -1310,6 +1308,10 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(IOBundleVector), target :: IOBundles type(IOBundleVectorIterator) :: bundle_iter type(ExtData_IOBundle), pointer :: io_bundle + + _UNUSED_DUMMY(IMPORT) + _UNUSED_DUMMY(EXPORT) + ! Declare pointers to IMPORT/EXPORT/INTERNAL states ! ------------------------------------------------- ! #include "MAPL_ExtData_DeclarePointer___.h" @@ -1557,7 +1559,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) io_bundle%pbundle = ESMF_FieldBundleCreate(rc=status) _VERIFY(STATUS) - call MAPL_ExtDataPopulateBundle(self,item,bracket_side,io_bundle%pbundle,rc=status) + call MAPL_ExtDataPopulateBundle(item,bracket_side,io_bundle%pbundle,rc=status) _VERIFY(status) call bundle_iter%next() enddo @@ -1670,7 +1672,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) if (doUpdate_) then - call CalcDerivedField(self%ExtDataState,self%primary,derivedItem%name,derivedItem%expression, & + call CalcDerivedField(self%ExtDataState,derivedItem%name,derivedItem%expression, & derivedItem%masking,__RC__) end if @@ -1983,7 +1985,7 @@ subroutine CreateTimeInterval(item,clock,rc) integer :: cindex,pindex character(len=ESMF_MAXSTR) :: creffTime, ctInt - __Iam__('CreateTimeInterval') + integer :: status creffTime = '' ctInt = '' @@ -2140,7 +2142,7 @@ subroutine GetLevs(item, time, allowExtrap, rc) logical , intent(in ) :: allowExtrap integer, optional , intent(out ) :: rc - __Iam__('GetLevs') + integer :: status integer(ESMF_KIND_I4) :: iyr,imm,idd,ihr,imn,iss,i,n,refYear character(len=ESMF_MAXPATHLEN) :: file @@ -2227,15 +2229,15 @@ subroutine GetLevs(item, time, allowExtrap, rc) var => null() if (item%isVector) then var=>metadata%get_variable(trim(item%fcomp1)) - _ASSERT(associated(var),"Variable not found in file") + _ASSERT(associated(var),"Variable "//TRIM(item%fcomp1)//" not found in file "//TRIM(item%file)) var => null() var=>metadata%get_variable(trim(item%fcomp2)) - _ASSERT(associated(var),"Variable not found in file") + _ASSERT(associated(var),"Variable "//TRIM(item%fcomp2)//" not found in file "//TRIM(item%file)) else var=>metadata%get_variable(trim(item%var)) - _ASSERT(associated(var),"Variable not found in file") + _ASSERT(associated(var),"Variable "//TRIM(item%var)//" not found in file "//TRIM(item%file)) end if - + levName = metadata%get_level_name(rc=status) _VERIFY(status) if (trim(levName) /='') then @@ -2289,7 +2291,7 @@ subroutine UpdateBracketTime(item,cTime,bSide,interpTime,fileTime,file_processed logical, intent(in ) :: allowExtrap integer, optional, intent(out ) :: rc - __Iam__('UpdateBracketTime') + integer :: status type(ESMF_Time) :: newTime integer :: curDate,curTime,n,tindex @@ -2309,7 +2311,6 @@ subroutine UpdateBracketTime(item,cTime,bSide,interpTime,fileTime,file_processed logical :: LExtrap, RExtrap, LExact, RExact logical :: LSide, RSide, intOK, bracketScan - type (ESMF_CFIO), pointer :: xCFIO type(ESMF_Time), allocatable :: xTSeries(:) type(FileMetaDataUtils), pointer :: fdata @@ -2833,7 +2834,6 @@ subroutine makeMetadata(file,collection_id,metadata,rc) type(FileMetadataUtils), pointer, intent(inout) :: metadata integer, optional, intent(out ) :: rc type(MAPLExtDataCollection), pointer :: collection => null() - integer :: status Collection => ExtDataCollections%at(collection_id) metadata => collection%find(file) @@ -2849,7 +2849,7 @@ subroutine GetTimesOnFile(cfio,tSeries,rc) type(ESMF_Time) :: tSeries(:) integer, optional, intent(out ) :: rc - __Iam__('GetTimesOnFile') + integer :: status integer(ESMF_KIND_I4) :: iyr,imm,idd,ihr,imn,isc integer :: i @@ -3321,15 +3321,14 @@ subroutine GetBracketTimeOnFile(fdata,tSeries,cTime,bSide,UniFileClim,interpTime end subroutine GetBracketTimeOnFile - subroutine CalcDerivedField(state,primaries,exportName,exportExpr,masking,rc) + subroutine CalcDerivedField(state,exportName,exportExpr,masking,rc) type(ESMF_State), intent(inout) :: state - type(PrimaryExports), intent(inout) :: primaries character(len=*), intent(in ) :: exportName character(len=*), intent(in ) :: exportExpr logical, intent(in ) :: masking integer, optional, intent(out ) :: rc - __Iam__('CalcDerivedField') + integer :: status type(ESMF_Field) :: field @@ -3516,22 +3515,21 @@ subroutine MAPL_ExtDataVerticalInterpolate(ExtState,item,filec,rc) integer, optional, intent(out ) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_ExtDataVerticalInterpolate" integer :: id_ps type(ESMF_Field) :: field, newfield,psF if (item%do_VertInterp) then if (trim(item%importVDir)/=trim(item%fileVDir)) then - call MAPL_ExtDataFlipVertical(ExtState,item,filec,rc=status) + call MAPL_ExtDataFlipVertical(item,filec,rc=status) _VERIFY(status) end if if (item%vartype == MAPL_fieldItem) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,rc=status) _VERIFY(STATUS) id_ps = ExtState%primaryOrder(1) - call MAPL_ExtDataGetBracket(ExtState,ExtState%primary%item(id_ps),filec,field=psF,rc=status) + call MAPL_ExtDataGetBracket(ExtState%primary%item(id_ps),filec,field=psF,rc=status) _VERIFY(STATUS) call vertInterpolation_pressKappa(field,newfield,psF,item%levs,MAPL_UNDEF,rc=status) _VERIFY(STATUS) @@ -3539,17 +3537,17 @@ subroutine MAPL_ExtDataVerticalInterpolate(ExtState,item,filec,rc) else if (item%vartype == MAPL_ExtDataVectorItem) then id_ps = ExtState%primaryOrder(1) - call MAPL_ExtDataGetBracket(ExtState,ExtState%primary%item(id_ps),filec,field=psF,rc=status) + call MAPL_ExtDataGetBracket(ExtState%primary%item(id_ps),filec,field=psF,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,vcomp=1,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,vcomp=1,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,vcomp=1,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,vcomp=1,rc=status) _VERIFY(STATUS) call vertInterpolation_pressKappa(field,newfield,psF,item%levs,MAPL_UNDEF,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,vcomp=2,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,vcomp=2,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,vcomp=2,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,vcomp=2,rc=status) _VERIFY(STATUS) call vertInterpolation_pressKappa(field,newfield,psF,item%levs,MAPL_UNDEF,rc=status) _VERIFY(STATUS) @@ -3558,29 +3556,29 @@ subroutine MAPL_ExtDataVerticalInterpolate(ExtState,item,filec,rc) else if (item%do_Fill) then if (item%vartype == MAPL_fieldItem) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,rc=status) _VERIFY(STATUS) call MAPL_ExtDataFillField(item,field,newfield,rc=status) _VERIFY(STATUS) else if (item%vartype == MAPL_ExtDataVectorItem) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,vcomp=1,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,vcomp=1,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,vcomp=1,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,vcomp=1,rc=status) _VERIFY(STATUS) call MAPL_ExtDataFillField(item,field,newfield,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,newField,getRL=.true.,vcomp=2,rc=status) + call MAPL_ExtDataGetBracket(item,filec,newField,getRL=.true.,vcomp=2,rc=status) _VERIFY(STATUS) - call MAPL_ExtDataGetBracket(ExtState,item,filec,Field,vcomp=2,rc=status) + call MAPL_ExtDataGetBracket(item,filec,Field,vcomp=2,rc=status) _VERIFY(STATUS) call MAPL_ExtDataFillField(item,field,newfield,rc=status) _VERIFY(STATUS) end if else if (trim(item%importVDir)/=trim(item%fileVDir)) then - call MAPL_ExtDataFlipVertical(ExtState,item,filec,rc=status) + call MAPL_ExtDataFlipVertical(item,filec,rc=status) _VERIFY(status) end if end if @@ -3594,7 +3592,6 @@ subroutine GetMaskName(FuncStr,Var,Needed,rc) logical, intent(inout) :: needed(:) integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR) :: Iam = "GetMaskName" integer :: status integer :: i1,i2,i,ivar logical :: found,twovar @@ -3651,7 +3648,6 @@ subroutine MAPL_ExtDataEvaluateMask(state,exportName,exportExpr,rc) character(len=*), intent(in) :: exportExpr integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR) :: Iam = "EvaluateMask" integer :: status integer :: k,i @@ -4116,7 +4112,7 @@ function MAPL_ExtDataGetFStartTime(item,fname, rc) result(stime) integer :: status - integer :: iyr,imm,idd,ihr,imn,isc,begDate,begTime + integer :: iyr,imm,idd,ihr,imn,isc type(FileMetadataUtils), pointer :: metadata => null() call MakeMetadata(fname,item%pfiocollection_id,metadata,__RC__) @@ -4292,6 +4288,7 @@ function MAPL_ExtDataGridChangeLev(Grid,CF,lm,rc) result(NewGrid) type(ESMF_Grid) :: newGrid type(ESMF_Config) :: cflocal character(len=*), parameter :: CF_COMPONENT_SEPARATOR = '.' + real :: temp_real IAM = "MAPL_ExtDataGridChangeLev" @@ -4319,6 +4316,21 @@ function MAPL_ExtDataGridChangeLev(Grid,CF,lm,rc) result(NewGrid) _VERIFY(status) call MAPL_ConfigSetAttribute(cflocal,value=trim(gname), label=trim(COMP_Name)//CF_COMPONENT_SEPARATOR//"GRIDNAME:",rc=status) _VERIFY(status) + call ESMF_AttributeGet(grid, name='STRETCH_FACTOR', value=temp_real, rc=status) + if (status == ESMF_SUCCESS) then + call MAPL_ConfigSetAttribute(cflocal,value=temp_real, label=trim(COMP_Name)//CF_COMPONENT_SEPARATOR//"STRETCH_FACTOR:",rc=status) + _VERIFY(status) + endif + call ESMF_AttributeGet(grid, name='TARGET_LON', value=temp_real, rc=status) + if (status == ESMF_SUCCESS) then + call MAPL_ConfigSetAttribute(cflocal,value=temp_real*MAPL_RADIANS_TO_DEGREES, label=trim(COMP_Name)//CF_COMPONENT_SEPARATOR//"TARGET_LON:",rc=status) + _VERIFY(status) + endif + call ESMF_AttributeGet(grid, name='TARGET_LAT', value=temp_real, rc=status) + if (status == ESMF_SUCCESS) then + call MAPL_ConfigSetAttribute(cflocal,value=temp_real*MAPL_RADIANS_TO_DEGREES, label=trim(COMP_Name)//CF_COMPONENT_SEPARATOR//"TARGET_LAT:",rc=status) + _VERIFY(status) + endif else call MAPL_ConfigSetAttribute(cflocal,value=counts(1), label=trim(COMP_Name)//CF_COMPONENT_SEPARATOR//"IM_WORLD:",rc=status) _VERIFY(status) @@ -4336,9 +4348,8 @@ function MAPL_ExtDataGridChangeLev(Grid,CF,lm,rc) result(NewGrid) end function MAPL_ExtDataGridChangeLev - subroutine MAPL_ExtDataGetBracket(ExtState,item,Bside,field,bundle,getRL,vcomp,rc) + subroutine MAPL_ExtDataGetBracket(item,Bside,field,bundle,getRL,vcomp,rc) - type(MAPL_ExtData_State), intent(inout) :: ExtState type(PrimaryExport), intent(inout) :: item integer, intent(in ) :: bside type(ESMF_Field), optional, intent(inout) :: field @@ -4348,10 +4359,8 @@ subroutine MAPL_ExtDataGetBracket(ExtState,item,Bside,field,bundle,getRL,vcomp,r integer, optional, intent(out ) :: rc character(len=ESMF_MAXSTR) :: Iam - integer :: status logical :: getRL_ - type(ESMF_Grid) :: grid,newGrid Iam = "MAPL_ExtDataGetBracket" @@ -4489,73 +4498,71 @@ subroutine MAPL_ExtDataFillField(item,FieldF,FieldR,rc) end subroutine MAPL_ExtDataFillField - subroutine MAPL_ExtDataFlipVertical(ExtState,item,filec,rc) - type(MAPL_ExtData_State), intent(inout) :: ExtState + subroutine MAPL_ExtDataFlipVertical(item,filec,rc) type(PrimaryExport), intent(inout) :: item integer, intent(in) :: filec integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam = "MAPL_ExtDataFlipVertical" type(ESMF_Field) :: Field,field1,field2 real, pointer :: ptr(:,:,:) real, allocatable :: ptemp(:,:,:) - integer :: lm + integer :: ls, le if (item%isVector) then if (item%do_Fill .or. item%do_VertInterp) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field1,vcomp=1,getRL=.true.,__RC__) - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field2,vcomp=2,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field1,vcomp=1,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field2,vcomp=2,getRL=.true.,__RC__) else - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field1,vcomp=1,__RC__) - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field2,vcomp=2,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field1,vcomp=1,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field2,vcomp=2,__RC__) end if call ESMF_FieldGet(Field1,0,farrayPtr=ptr,rc=status) _VERIFY(STATUS) allocate(ptemp,source=ptr,stat=status) _VERIFY(status) - lm = size(ptr,3) - ptr(:,:,lm:1:-1) = ptemp(:,:,1:lm:+1) + ls = lbound(ptr,3) + le = ubound(ptr,3) + ptr(:,:,le:ls:-1) = ptemp(:,:,ls:le:+1) call ESMF_FieldGet(Field2,0,farrayPtr=ptr,rc=status) _VERIFY(STATUS) ptemp=ptr - ptr(:,:,lm:1:-1) = ptemp(:,:,1:lm:+1) + ptr(:,:,le:ls:-1) = ptemp(:,:,ls:le:+1) deallocate(ptemp) else if (item%do_Fill .or. item%do_VertInterp) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field,getRL=.true.,__RC__) else - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field,__RC__) end if call ESMF_FieldGet(Field,0,farrayPtr=ptr,rc=status) _VERIFY(STATUS) allocate(ptemp,source=ptr,stat=status) _VERIFY(status) - lm = size(ptr,3) - ptr(:,:,lm:1:-1) = ptemp(:,:,1:lm:+1) + ls = lbound(ptr,3) + le = ubound(ptr,3) + ptr(:,:,le:ls:-1) = ptemp(:,:,ls:le:+1) deallocate(ptemp) end if _RETURN(ESMF_SUCCESS) end subroutine MAPL_ExtDataFlipVertical - subroutine MAPL_ExtDataPopulateBundle(ExtState,item,filec,pbundle,rc) - type(MAPL_ExtData_State), intent(inout) :: ExtState + subroutine MAPL_ExtDataPopulateBundle(item,filec,pbundle,rc) type(PrimaryExport), intent(inout) :: item integer, intent(in) :: filec type(ESMF_FieldBundle), intent(inout) :: pbundle integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam = "MAPL_ExtDataPopulateBundle" type(ESMF_Field) :: Field,field1,field2 type(ESMF_Grid) :: grid @@ -4563,11 +4570,11 @@ subroutine MAPL_ExtDataPopulateBundle(ExtState,item,filec,pbundle,rc) if (item%isVector) then if (item%do_Fill .or. item%do_VertInterp) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field1,vcomp=1,getRL=.true.,__RC__) - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field2,vcomp=2,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field1,vcomp=1,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field2,vcomp=2,getRL=.true.,__RC__) else - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field1,vcomp=1,__RC__) - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field2,vcomp=2,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field1,vcomp=1,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field2,vcomp=2,__RC__) end if call ESMF_FieldGet(Field1,grid=grid,rc=status) @@ -4591,9 +4598,9 @@ subroutine MAPL_ExtDataPopulateBundle(ExtState,item,filec,pbundle,rc) else if (item%do_Fill .or. item%do_VertInterp) then - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field,getRL=.true.,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field,getRL=.true.,__RC__) else - call MAPL_ExtDataGetBracket(ExtState,item,filec,field=Field,__RC__) + call MAPL_ExtDataGetBracket(item,filec,field=Field,__RC__) end if call ESMF_FieldGet(Field,grid=grid,rc=status) @@ -4615,7 +4622,7 @@ subroutine MAPL_ExtDataCreateCFIO(IOBundles, rc) type (IoBundleVectorIterator) :: bundle_iter type (ExtData_IoBundle), pointer :: io_bundle - __Iam__('MAPL_ExtDataCreateCFIO') + integer :: status bundle_iter = IOBundles%begin() do while (bundle_iter /= IOBundles%end()) @@ -4634,7 +4641,7 @@ subroutine MAPL_ExtDataDestroyCFIO(IOBundles,rc) type(IoBundleVectorIterator) :: bundle_iter type (ExtData_IoBundle), pointer :: io_bundle - __Iam__('MAPL_ExtDataDestroyCFIO') + integer :: status bundle_iter = IOBundles%begin() do while (bundle_iter /= IOBundles%end()) @@ -4656,8 +4663,6 @@ subroutine MAPL_ExtDataPrefetch(IOBundles,rc) type(ExtData_IoBundle), pointer :: io_bundle => null() integer :: status - logical :: init = .false. - nfiles = IOBundles%size() do n = 1, nfiles @@ -4676,7 +4681,7 @@ subroutine MAPL_ExtDataReadPrefetch(IOBundles,rc) integer :: nfiles, n type (ExtData_IoBundle), pointer :: io_bundle - __Iam__('MAPL_ExtDataReadPrefetch') + integer :: status nfiles = IOBundles%size() @@ -4696,7 +4701,6 @@ subroutine createFileLevBracket(item,cf,rc) integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam = "createFileLevBracket" type (ESMF_Grid) :: grid, newgrid if (item%vartype==MAPL_FieldItem) then @@ -4729,7 +4733,7 @@ subroutine IOBundle_Add_Entry(IOBundles,item,entry_num,file,bside,time_index,rc) integer, intent(in) :: time_index integer, intent(out), optional :: rc - __Iam__('IOBUNDLE_Add_Entry') + integer :: status type (ExtData_IOBundle) :: io_bundle type (NewCFIOItemVector) :: items diff --git a/MAPL_Base/MAPL_ExtData_IOBundleMod.F90 b/MAPL_Base/MAPL_ExtData_IOBundleMod.F90 index f2d673f3c34c..9b0bc504f4a0 100644 --- a/MAPL_Base/MAPL_ExtData_IOBundleMod.F90 +++ b/MAPL_Base/MAPL_ExtData_IOBundleMod.F90 @@ -49,8 +49,6 @@ module MAPL_ExtData_IOBundleMod function new_ExtData_IoBundle(bracket_side, entry_index, file_name, time_index, regrid_method, fraction, template, metadata_coll_id,server_coll_id,items,rc) result(io_bundle) type (ExtData_IoBundle) :: io_bundle - __Iam__('new_ExtData_IoBundle') - integer, intent(in) :: bracket_side integer, intent(in) :: entry_index character(len=*), intent(in) :: file_name @@ -83,8 +81,9 @@ subroutine clean(this, rc) class (ExtData_IoBundle), intent(inout) :: this integer, optional, intent(out) :: rc - __Iam__('clean') - call ESMF_FieldBundleDestroy(this%pbundle, noGarbage=.true.,__RC__) + integer :: status + call ESMF_FieldBundleDestroy(this%pbundle, noGarbage=.true.,rc=status) + _VERIFY(status) _RETURN(ESMF_SUCCESS) @@ -96,8 +95,6 @@ subroutine make_cfio(this, rc) class (ExtData_IoBundle), intent(inout) :: this integer, optional, intent(out) :: rc - __Iam__('make_cfio') - this%cfio = MAPL_NewCFIO(output_bundle=this%pbundle,regrid_method=this%regrid_method, & read_collection_id=this%server_coll_id, & metadata_collection_id = this%metadata_coll_id, fraction = this%fraction, & diff --git a/MAPL_Base/MAPL_FlapCapOptions.F90 b/MAPL_Base/MAPL_FlapCapOptions.F90 index 8a3aed1f79e7..cea574ddf09f 100644 --- a/MAPL_Base/MAPL_FlapCapOptions.F90 +++ b/MAPL_Base/MAPL_FlapCapOptions.F90 @@ -8,6 +8,7 @@ module MAPL_FlapCapOptionsMod use MAPL_KeywordEnforcerMod use MAPL_ErrorHandlingMod use MAPL_CapOptionsMod + use pflogger implicit none private @@ -163,6 +164,14 @@ subroutine add_command_line_options(options, unusable, rc) error=status) _VERIFY(status) + call options%add(switch='--logging_config', & + help='Configuration file for logging', & + required=.false., & + def='', & + act='store', & + error=status) + _VERIFY(status) + _RETURN(_SUCCESS) end subroutine add_command_line_options @@ -213,6 +222,10 @@ subroutine parse_command_line_arguments(this, unusable, rc) call this%cli_options%get(val=buffer, switch='--cap_rc', error=status); _VERIFY(status) this%cap_rc_file = trim(buffer) + ! Logging options + call this%cli_options%get(val=buffer, switch='--logging_config', error=status); _VERIFY(status) + this%logging_config = trim(buffer) + end subroutine parse_command_line_arguments subroutine set_esmf_logging_mode(this, flag_name, unusable, rc) @@ -238,4 +251,5 @@ subroutine set_esmf_logging_mode(this, flag_name, unusable, rc) _RETURN(_SUCCESS) end subroutine set_esmf_logging_mode + end module MAPL_FlapCapOptionsMod diff --git a/MAPL_Base/MAPL_Generic.F90 b/MAPL_Base/MAPL_Generic.F90 index a9b99e498887..f390c35189e6 100644 --- a/MAPL_Base/MAPL_Generic.F90 +++ b/MAPL_Base/MAPL_Generic.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" #define GET_POINTER ESMFL_StateGetPointerToData @@ -115,6 +114,7 @@ module MAPL_GenericMod use MAPL_BaseMod use MAPL_IOMod use MAPL_ProfMod + use MAPL_Profiler use MAPL_MemUtilsMod use MAPL_CommsMod use MAPL_ConstantsMod @@ -124,8 +124,10 @@ module MAPL_GenericMod use MAPL_LocStreamMod use MAPL_ConfigMod use MAPL_ErrorHandlingMod + use pFlogger, only: logging, Logger use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 + use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT ! !PUBLIC MEMBER FUNCTIONS: @@ -147,6 +149,7 @@ module MAPL_GenericMod public MAPL_GetObjectFromGC public MAPL_Get public MAPL_Set + public MAPL_InternalStateCreate public MAPL_GenericRunCouplers public MAPL_ChildAddAttribToImportSpec @@ -201,7 +204,8 @@ module MAPL_GenericMod public MAPL_GCGet public MAPL_CheckpointState public MAPL_ESMFStateReadFromFile - + public MAPL_InternalStateRetrieve + public :: MAPL_GetLogger !BOP ! !PUBLIC TYPES: @@ -395,6 +399,10 @@ module MAPL_GenericMod integer , pointer :: phase_coldstart(:)=> null() real :: HEARTBEAT type (MAPL_Communicators) :: mapl_comm + type (TimeProfiler), public :: t_profiler + character(:), allocatable :: full_name ! Period separated list of ancestor names + class(Logger), pointer :: lgr + !!$ integer :: comm end type MAPL_MetaComp !EOC @@ -428,6 +436,7 @@ module MAPL_GenericMod type(MAPL_MetaComp), pointer :: PTR end type MAPL_MetaPtr +character(*), parameter :: SEPARATOR = '.' include "netcdf.inc" contains @@ -544,8 +553,7 @@ recursive subroutine MAPL_GenericSetServices ( GC, RC ) call MAPL_InternalStateRetrieve( GC, MAPLOBJ, RC=STATUS) _VERIFY(STATUS) - MAPLOBJ%COMPNAME = COMP_NAME - + call MAPLOBJ%t_profiler%start('GenSetService') ! Set the Component's Total timer ! ------------------------------- @@ -783,6 +791,7 @@ recursive subroutine MAPL_GenericSetServices ( GC, RC ) ! All done !--------- + call MAPLOBJ%t_profiler%stop('GenSetService') _RETURN(ESMF_SUCCESS) @@ -888,6 +897,7 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) logical :: isPresent logical :: isCreated logical :: gridIsPresent + class(BaseProfiler), pointer :: t_p character(len=ESMF_MAXSTR) :: write_restart_by_face character(len=ESMF_MAXSTR) :: read_restart_by_face character(len=ESMF_MAXSTR) :: write_restart_by_oserver @@ -912,10 +922,13 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Start my timer !--------------- + + call state%t_profiler%start('GenInitialize') call MAPL_GenericStateClockOn(STATE,"TOTAL") call MAPL_GenericStateClockOn(STATE,"GenInitTot") call MAPL_GenericStateClockOn(STATE,"--GenInitMine") + call state%t_profiler%start('GenInitialize_self') ! Put the inherited grid in the generic state !-------------------------------------------- @@ -1437,6 +1450,7 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) STATE%RECORD%INT_LEN = 0 end if end if + call state%t_profiler%stop('GenInitialize_self') call MAPL_GenericStateClockOff(STATE,"--GenInitMine") ! Initialize the children @@ -1469,14 +1483,21 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_GridCompGet( STATE%GCS(I), NAME=CHILD_NAME, RC=STATUS ) _VERIFY(STATUS) + t_p => get_global_time_profiler() + call t_p%start(trim(CHILD_NAME)) call MAPL_GenericStateClockOn (STATE,trim(CHILD_NAME)) + call CHLDMAPL(I)%ptr%t_profiler%start() + call CHLDMAPL(I)%ptr%t_profiler%start('Initialize') call ESMF_GridCompInitialize (STATE%GCS(I), & importState=STATE%GIM(I), & exportState=STATE%GEX(I), & clock=CLOCK, PHASE=CHLDMAPL(I)%PTR%PHASE_INIT(PHASE), & userRC=userRC, RC=STATUS ) _ASSERT(userRC==ESMF_SUCCESS .and. STATUS==ESMF_SUCCESS,'needs informative message') + call CHLDMAPL(I)%ptr%t_profiler%stop('Initialize') + call CHLDMAPL(I)%ptr%t_profiler%stop() call MAPL_GenericStateClockOff(STATE,trim(CHILD_NAME)) + call t_p%stop(trim(CHILD_NAME)) end if end do deallocate(CHLDMAPL) @@ -1513,6 +1534,7 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) enddo endif call MAPL_GenericStateClockOn(STATE,"--GenInitMine") + call state%t_profiler%start('GenInitialize_self') ! Create import and initialize state variables ! -------------------------------------------- @@ -1659,7 +1681,8 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(STATUS) end if - call MAPL_GenericStateClockOff(STATE,"--GenInitMine") + call state%t_profiler%stop('GenInitialize_self') + call MAPL_GenericStateClockOff(STATE,"--GenInitMine") if (.not. associated(STATE%parentGC)) then call MAPL_AdjustIsNeeded(GC, EXPORT, RC=STATUS) @@ -1669,6 +1692,8 @@ recursive subroutine MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GenericStateClockOff(STATE,"GenInitTot") call MAPL_GenericStateClockOff(STATE,"TOTAL") + call state%t_profiler%stop('GenInitialize') + ! Write Memory Use Statistics. ! ------------------------------------------- call MAPL_MemUtilsWrite(VM, Iam, RC=STATUS ) @@ -1711,6 +1736,8 @@ subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) integer :: I type(ESMF_Method_Flag) :: method type(ESMF_VM) :: VM + class(BaseProfiler), pointer :: t_p + character(1) :: char_phase character(len=12), pointer :: timers(:) => NULL() ! the next declaration assumes all 5 methods have the same signature @@ -1748,10 +1775,16 @@ subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) ! TIMERS on + t_p => get_global_time_profiler() + MethodBlock: if (method == ESMF_METHOD_RUN) then func_ptr => ESMF_GridCompRun timers => timers_run sbrtn = 'Run' + if (phase > 1) then + write(char_phase,'(i1)')phase + sbrtn = 'Run'//char_phase + end if else if (method == ESMF_METHOD_INITIALIZE) then func_ptr => ESMF_GridCompInitialize !ALT: enable this when fully implemented (for now NULLIFY) @@ -1779,6 +1812,19 @@ subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) endif MethodBlock ! TIMERS on + if (method == ESMF_METHOD_RUN ) then + call t_p%start(trim(state%compname)) + call state%t_profiler%start() + call state%t_profiler%start(trim(sbrtn)) + endif + + if (method == ESMF_METHOD_FINALIZE ) then + call t_p%start(trim(state%compname)) + call state%t_profiler%start() + call state%t_profiler%start('Finalize') + endif + + if (associated(timers)) then do i = 1, size(timers) call MAPL_TimerOn (STATE,timers(i)) @@ -1787,13 +1833,13 @@ subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) ! Method itself ! ---------- - #ifdef DEBUG IF (mapl_am_i_root(vm)) then print *,'DBG: running ', sbrtn, ' phase ',phase,' of ',trim(COMP_NAME) end IF #endif + call func_ptr (GC, & importState=IMPORT, & exportState=EXPORT, & @@ -1808,6 +1854,13 @@ subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) end do end if + if (method == ESMF_METHOD_RUN) then + call state%t_profiler%stop(trim(sbrtn)) + call state%t_profiler%stop() + call t_p%stop(trim(state%compname)) + endif + + _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericWrapper @@ -1957,7 +2010,7 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXSTR) :: CHILD_NAME character(len=ESMF_MAXSTR) :: RECFIN type (MAPL_MetaComp), pointer :: STATE - integer :: I,j + integer :: I logical :: final_checkpoint integer :: NC integer :: PHASE @@ -1971,6 +2024,8 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXSTR) :: id_string integer :: ens_id_width type(ESMF_Time) :: CurrTime + class(BaseProfiler), pointer :: t_p + !============================================================================= ! Begin... @@ -1992,6 +2047,11 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Finalize the children ! --------------------- + t_p => get_global_time_profiler() + !call t_p%start(trim(state%compname)) + !call state%t_profiler%start() + !call state%t_profiler%start('Final') + call MAPL_GenericStateClockOn(STATE,"TOTAL") call MAPL_GenericStateClockOn(STATE,"GenFinalTot") if(associated(STATE%GCS)) then @@ -2026,6 +2086,7 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) endif call MAPL_GenericStateClockOn(STATE,"--GenFinalMine") + call state%t_profiler%start('Final_self') call MAPL_GetResource( STATE, RECFIN, LABEL="RECORD_FINAL:", & RC=STATUS ) @@ -2116,14 +2177,22 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) endif end if + call state%t_profiler%stop('Final_self') call MAPL_GenericStateClockOff(STATE,"--GenFinalMine") call MAPL_GenericStateClockOff(STATE,"GenFinalTot") call MAPL_GenericStateClockOff(STATE,"TOTAL") ! Write summary of profiled times !-------------------------------- + + call state%t_profiler%stop('Finalize') + call state%t_profiler%stop() if (.not. MAPL_ProfIsDisabled()) then + + call report_generic_profile() + + ! WJ node: the old report will be removed call WRITE_PARALLEL(" ") call WRITE_PARALLEL(" Times for "//trim(COMP_NAME)) @@ -2133,17 +2202,55 @@ recursive subroutine MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC ) call WRITE_PARALLEL(" ") end if + call t_p%stop(trim(state%compname)) + ! Clean-up !--------- !ALT - call MAPL_GenericStateDestroy (STATE, RC=STATUS) - _VERIFY(STATUS) -! call ESMF_StateDestroy (IMPORT, RC=STATUS) -! _VERIFY(STATUS) -! call ESMF_StateDestroy (EXPORT, RC=STATUS) -! _VERIFY(STATUS) + call MAPL_GenericStateDestroy (STATE, RC=STATUS) + _VERIFY(STATUS) _RETURN(ESMF_SUCCESS) + +contains + + subroutine report_generic_profile( rc ) + integer, optional, intent( out) :: RC ! Error code: + character(:), allocatable :: report(:) + type (ProfileReporter) :: reporter + type (MultiColumn) :: inclusive, exclusive + type (ESMF_VM) :: vm + character(1) :: empty(0) + + call ESMF_VmGetCurrent(vm, rc=status) + _VERIFY(STATUS) + + if (MAPL_AM_I_Root(vm)) then + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(50 , separator=" ")) + call reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn(),separator='-')) + inclusive = MultiColumn(['Inclusive'], separator='=') + call inclusive%add_column(FormattedTextColumn(' T (sec) ','(f9.3)', 9, InclusiveColumn(), separator='-')) + call inclusive%add_column(FormattedTextColumn(' % ','(f6.2)', 6, PercentageColumn(InclusiveColumn(),'MAX'),separator='-')) + call reporter%add_column(inclusive) + exclusive = MultiColumn(['Exclusive'], separator='=') + call exclusive%add_column(FormattedTextColumn(' T (sec) ','(f9.3)', 9, ExclusiveColumn(), separator='-')) + call exclusive%add_column(FormattedTextColumn(' % ','(f6.2)', 6, PercentageColumn(ExclusiveColumn()), separator='-')) + call reporter%add_column(exclusive) + + report = reporter%generate_report(state%t_profiler) + write(OUTPUT_UNIT,*)'' + write(OUTPUT_UNIT,*)'Time for ' // trim(comp_name) + do i = 1, size(report) + write(OUTPUT_UNIT,'(a)')report(i) + end do + write(OUTPUT_UNIT,*)'' + end if + + _RETURN(ESMF_SUCCESS) + end subroutine report_generic_profile + end subroutine MAPL_GenericFinalize @@ -2184,6 +2291,7 @@ recursive subroutine MAPL_GenericRecord ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: K logical :: ftype(0:1) + class(BaseProfiler), pointer :: t_p !============================================================================= ! Begin... @@ -2199,6 +2307,12 @@ recursive subroutine MAPL_GenericRecord ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_InternalStateRetrieve(GC, STATE, RC=STATUS) _VERIFY(STATUS) + t_p => get_global_time_profiler() + call t_p%start(trim(state%compname)) + call state%t_profiler%start() + call state%t_profiler%start('Record') + + call MAPL_GenericStateClockOn(STATE,"TOTAL") call MAPL_GenericStateClockOn(STATE,"GenRecordTot") ! Record the children @@ -2220,6 +2334,8 @@ recursive subroutine MAPL_GenericRecord ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Do my "own" record ! ------------------ call MAPL_GenericStateClockOn(STATE,"--GenRecordMine") + call state%t_profiler%start('Record_self') + if (associated(STATE%RECORD)) then FILETYPE = MAPL_Write2Disk @@ -2285,11 +2401,14 @@ recursive subroutine MAPL_GenericRecord ( GC, IMPORT, EXPORT, CLOCK, RC ) end if END DO endif + call state%t_profiler%stop('Record_self') call MAPL_GenericStateClockOff(STATE,"--GenRecordMine") - call MAPL_GenericStateClockOff(STATE,"GenRecordTot") call MAPL_GenericStateClockOff(STATE,"TOTAL") + call state%t_profiler%stop('Record') + call state%t_profiler%stop() + call t_p%stop(trim(state%compname)) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericRecord @@ -2397,7 +2516,7 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) character(len=ESMF_MAXSTR) :: filetypechar character(len=4) :: extension integer :: hdr - + class(BaseProfiler), pointer :: t_p !============================================================================= ! Begin... @@ -2413,6 +2532,11 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_InternalStateRetrieve(GC, STATE, RC=STATUS) _VERIFY(STATUS) + t_p => get_global_time_profiler() + call t_p%start(trim(state%compname)) + call state%t_profiler%start() + call state%t_profiler%start('Refresh') + call MAPL_GenericStateClockOn(STATE,"TOTAL") call MAPL_GenericStateClockOn(STATE,"GenRefreshTot") ! Refresh the children @@ -2432,6 +2556,8 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Do my "own" refresh ! ------------------ call MAPL_GenericStateClockOn(STATE,"--GenRefreshMine") + call state%t_profiler%start('Refresh_self') + if (associated(STATE%RECORD)) then ! add timestamp to filename @@ -2489,10 +2615,13 @@ recursive subroutine MAPL_GenericRefresh ( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(STATUS) endif call MAPL_GenericStateClockOff(STATE,"--GenRefreshMine") - call MAPL_GenericStateClockOff(STATE,"GenRefreshTot") call MAPL_GenericStateClockOff(STATE,"TOTAL") + call state%t_profiler%stop('Refresh_self') + call state%t_profiler%stop('Refresh') + call state%t_profiler%stop() + call t_p%stop(trim(state%compname)) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericRefresh @@ -2632,7 +2761,6 @@ subroutine MAPL_InternalStateCreate( GC, MAPLOBJ, RC) character(len=ESMF_MAXSTR) :: IAm character(len=ESMF_MAXSTR) :: COMP_NAME integer :: STATUS - ! Local variables ! --------------- @@ -2867,7 +2995,6 @@ subroutine MAPL_InternalStateRetrieve(GC, MAPLOBJ, RC) ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm="MAPL_InternalStateRetrieve" integer :: STATUS ! Local variables @@ -3528,11 +3655,9 @@ subroutine MAPL_GridCompSetEntryPoint(GC, registeredMethod, usersRoutine, RC) !EOPI integer :: status - character(len=ESMF_MAXSTR) :: IAm type (MAPL_MetaComp), pointer :: META integer :: phase - integer :: phase0, phase1 call MAPL_InternalStateRetrieve( GC, META, RC=STATUS) _VERIFY(STATUS) @@ -3743,6 +3868,14 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & 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 + if(present(IM)) then IM=STATE%GRID%IM endif @@ -3783,6 +3916,20 @@ 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 @@ -3795,23 +3942,115 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & 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 , & + call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", default=23.45, & RC=STATUS) _VERIFY(STATUS) - call MAPL_GetResource(STATE, PER, Label="PERIHELION:" , default=102.0 , & + call MAPL_GetResource(STATE, PER, Label="PERIHELION:", default=102.0, & RC=STATUS) _VERIFY(STATUS) - call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:" , default=80 , & + call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", default=80, & RC=STATUS) _VERIFY(STATUS) - STATE%ORBIT = MAPL_SunOrbitCreate(STATE%CLOCK,ECC,OB,PER,EQNX,FIX_SUN=FIX_SUN,RC=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) + + ! 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) end if @@ -3984,6 +4223,10 @@ subroutine MAPL_GenericStateSet (STATE, ORBIT, LM, RUNALARM, CHILDINIT, & if(present(NAME)) then STATE%COMPNAME=NAME + if (.not. allocated(state%full_name)) then + state%full_name = trim(name) + state%lgr => logging%get_logger(trim(name)) + end if endif if(present(Cf)) then @@ -4192,7 +4435,6 @@ recursive integer function MAPL_AddChildFromMeta(META, NAME, GRID, & integer, optional , intent( OUT) :: rc !EOPI - character(len=ESMF_MAXSTR) :: IAm='MAPL_AddChildFromMeta' integer :: STATUS integer :: I @@ -4204,6 +4446,11 @@ recursive integer function MAPL_AddChildFromMeta(META, NAME, GRID, & character(len=ESMF_MAXSTR) :: FNAME, PNAME type(ESMF_GridComp) :: pGC type(ESMF_Context_Flag) :: contextFlag + class(BaseProfiler), pointer :: t_p + + class(Logger), pointer :: lgr + + lgr => logging%get_logger('MAPL.GENERIC') if (.not.associated(META%GCS)) then ! this is the first child to be added @@ -4216,6 +4463,7 @@ recursive integer function MAPL_AddChildFromMeta(META, NAME, GRID, & allocate(META%GCNameList(0), stat=status) _VERIFY(STATUS) end if + I = size(META%GCS) + 1 MAPL_AddChildFromMeta = I ! realloc GCS, gcnamelist @@ -4304,10 +4552,26 @@ recursive integer function MAPL_AddChildFromMeta(META, NAME, GRID, & CHILD_META%parentGC = parentGC end if + + call lgr%debug('Adding logger for component %a ',trim(fname)) + child_meta%full_name = meta%full_name // SEPARATOR // trim(fname) + child_meta%compname = trim(fname) + child_meta%lgr => logging%get_logger(child_meta%full_name) + ! copy communicator to childs mapl_metacomp CHILD_META%mapl_comm = META%mapl_comm + CHILD_META%t_profiler = TimeProfiler(trim(NAME), comm_world = META%mapl_comm%esmf%comm ) + + t_p => get_global_time_profiler() + call t_p%start(trim(NAME)) + call CHILD_META%t_profiler%start() + call CHILD_META%t_profiler%start('SetService') call ESMF_GridCompSetServices ( META%GCS(I), SS, RC=status ) + call CHILD_META%t_profiler%stop('SetService') + call CHILD_META%t_profiler%stop() + call t_p%stop(trim(NAME)) + _VERIFY(STATUS) _RETURN(ESMF_SUCCESS) @@ -4719,16 +4983,17 @@ subroutine MAPL_GenericStateClockOn(STATE,NAME,RC) !EOPI character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_GenericStateClockOn" - integer :: STATUS - + integer :: STATUS, n + call MAPL_ProfClockOn(STATE%TIMES,NAME,RC=STATUS) _VERIFY(STATUS) + + !n = index(NAME,'-',.true.) + 1 + !call state%t_profiler%start(trim(Name(n:))) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericStateClockOn - - subroutine MAPL_StateAlarmAdd(STATE,ALARM,RC) type (MAPL_MetaComp), intent(INOUT) :: STATE @@ -4788,11 +5053,14 @@ subroutine MAPL_GenericStateClockOff(STATE,NAME,RC) !EOPI character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_GenericStateClockOff" - integer :: STATUS + integer :: STATUS, n call MAPL_ProfClockOff(STATE%TIMES,NAME,RC=STATUS) _VERIFY(STATUS) + !n = index(NAME,'-',.true.) + 1 + !call state%t_profiler%stop(trim(Name(n:))) + _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericStateClockOff @@ -4829,7 +5097,6 @@ subroutine MAPL_GenericStateClockAdd(GC, NAME, RC) end subroutine MAPL_GenericStateClockAdd - !============================================================================= !============================================================================= !============================================================================= @@ -6091,8 +6358,6 @@ subroutine MAPL_StateGetVarSpecs(STATE,IMPORT,EXPORT,INTERNAL,RC) ! ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_StateGetVarSpec' - ! Begin ! Get the specs for the 3 ESMF states @@ -6895,7 +7160,6 @@ subroutine MAPL_FriendlyGet ( GC, NAME, FIELD, REQUESTOR, RC ) ! ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_FriendlyGet' integer :: STATUS ! Local variables @@ -7011,7 +7275,6 @@ subroutine MAPL_GridCompGetFriendlies0 ( GC, TO, BUNDLE, AddGCPrefix, RC ) ! ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_GridCompGetFriendlies0' integer :: STATUS ! Local variables @@ -7288,7 +7551,6 @@ subroutine MAPL_GridCompGetFriendlies2 ( GC, TO, BUNDLE, AddGCPrefix, RC ) ! ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_GridCompGetFriendlies2' integer :: STATUS, I character(len=ESMF_MAXSTR) :: TO_(1) @@ -7315,7 +7577,6 @@ subroutine MAPL_GridCompGetFriendlies3 ( GC, TO, BUNDLE, AddGCPrefix, RC ) ! ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_GridCompGetFriendlies3' integer :: STATUS, I do I=1,size(GC) @@ -7336,7 +7597,6 @@ subroutine MAPL_SetVarSpecForCC(gcA, gcB, ccAxB, rc) integer, optional, intent( out) :: RC ! Error code: ! Local vars - character(len=ESMF_MAXSTR) :: Iam="MAPL_SetVarSpecForCC" character(len=ESMF_MAXSTR) :: NAME integer :: STATUS integer :: I, N, STAT @@ -8380,7 +8640,6 @@ subroutine MAPL_ReadForcing1(STATE,NAME,DATAFILE,CURRENTTIME, & integer, optional, intent( OUT) :: RC !EOPI - character(len=ESMF_MAXSTR) :: IAm = "MAPL_ReadForcing1" integer :: STATUS call MAPL_ReadForcingX(STATE,NAME,DATAFILE,CURRENTTIME, & @@ -8410,7 +8669,6 @@ subroutine MAPL_ReadForcing2(STATE,NAME,DATAFILE,CURRENTTIME, & integer, optional, intent( OUT) :: RC !EOPI - character(len=ESMF_MAXSTR) :: IAm = "MAPL_ReadForcing2" integer :: STATUS call MAPL_ReadForcingX(STATE,NAME,DATAFILE,CURRENTTIME, & @@ -8438,7 +8696,6 @@ subroutine MAPL_ReadForcingX(MPL,NAME,DATAFILE,CURRTIME, & ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm = "MAPL_ReadForcing" integer :: STATUS ! Locals @@ -9176,7 +9433,6 @@ subroutine MAPL_StateGetTimeStamp(STATE,NAME,TIME,RC) ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm = "MAPL_StateGetTimeStamp" integer :: STATUS ! Locals @@ -9216,7 +9472,6 @@ subroutine MAPL_StateSetTimeStamp(STATE,NAME,TIME,RC) ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm = "MAPL_StateSetTimeStamp" integer :: STATUS ! Locals @@ -9246,7 +9501,6 @@ subroutine MAPL_GenericMakeXchgNatural(STATE, RC) ! ErrLog Variables - character(len=ESMF_MAXSTR) :: IAm = "MAPL_GenericMakeXchgNatural" STATE%LOCSTREAM = STATE%ExchangeGrid @@ -9272,7 +9526,6 @@ subroutine MAPL_GridCreate(GC, MAPLOBJ, ESMFGRID, srcGC, rc) integer :: nn,ny character(len=ESMF_MAXSTR) :: GridName character(len=2) :: dateline - real(ESMF_KIND_R8), pointer :: R8D2(:,:) #ifdef CREATE_REGULAR_GRIDS logical :: isRegular #endif @@ -9388,7 +9641,6 @@ subroutine MAPL_GridCoordAdjustFromFile(GRID, GRIDSPECFILE, RC) ! local vars !------------ - character(len=ESMF_MAXSTR) :: IAm='MAPL_GridCoordAdjustFromFile' integer :: STATUS integer :: UNIT integer :: IM, JM @@ -9471,7 +9723,6 @@ recursive subroutine MAPL_GetRootGC(GC, rootGC, RC) integer, optional, intent(OUT) :: rc integer :: status - character(len=ESMF_MAXSTR) :: IAm type (MAPL_MetaComp), pointer :: META call MAPL_GetObjectFromGC(GC, META, RC=STATUS) @@ -9651,7 +9902,6 @@ function MAPL_GridGetSection(Grid, SectionMap, GridName, RC) result(SECTION) character(len=ESMF_MAXSTR) :: name integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_GridGetSection" call ESMF_GridGet(GRID, Name=Name, DistGrid=distgrid, dimCount=dimCount, RC=STATUS) _VERIFY(STATUS) @@ -9751,7 +10001,6 @@ subroutine MAPL_InternalGridSet(MYGRID, GRID, RC) type(ESMF_VM) :: vm integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_InternalGridSet" ! At this point, this component must have a valid grid! !------------------------------------------------------ @@ -9887,7 +10136,6 @@ recursive subroutine MAPL_GetAllExchangeGrids ( GC, LSADDR, RC ) integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_GetAllExchangeGrids" type (MAPL_MetaComp), pointer :: MAPLOBJ type (MAPL_LocStream) :: LocStream @@ -9957,7 +10205,6 @@ subroutine MAPL_DoNotAllocateImport(GC, NAME, notFoundOK, RC) integer, optional, intent( OUT) :: RC ! Return code integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_DoNotAllocateImport" type (MAPL_MetaComp), pointer :: MAPLOBJ type (MAPL_VarSpec), pointer :: SPEC(:) => null() @@ -9983,7 +10230,6 @@ subroutine MAPL_DoNotAllocateInternal(GC, NAME, notFoundOK, RC) integer, intent( OUT) :: RC ! Return code integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_DoNotAllocateInternal" type (MAPL_MetaComp), pointer :: MAPLOBJ type (MAPL_VarSpec), pointer :: SPEC(:) @@ -10007,7 +10253,6 @@ subroutine MAPL_DoNotAllocateVar(SPEC, NAME, notFoundOK, RC) integer, optional, intent( OUT) :: RC ! Return code integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_DoNotAllocateVar" integer :: I logical :: notFoundOK_ @@ -10046,7 +10291,6 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, logical :: tile_loc type(ESMF_Grid) :: TILEGRID character(len=MPI_MAX_INFO_VAL) :: romio_cb_read,cb_buffer_size,romio_cb_write - character(len=ESMF_MAXSTR) :: Iam="ArrDescrSetNCPar" if (present(tile)) then tile_loc=tile @@ -10148,4 +10392,19 @@ end subroutine set_arrdes_by_face end subroutine ArrDescrSetNCPar + subroutine MAPL_GetLogger(gc, lgr, rc) + type(ESMF_GridComp), intent(inout) :: gc + class(Logger), pointer :: lgr + integer, optional, intent(out) :: rc + type (MAPL_MetaComp), pointer :: meta + + integer :: status + + call MAPL_GetObjectFromGC(gc, meta, rc=status) + _VERIFY(status) + + lgr => meta%lgr + _RETURN(_SUCCESS) + end subroutine MAPL_GetLogger + end module MAPL_GenericMod diff --git a/MAPL_Base/MAPL_GenericCplComp.F90 b/MAPL_Base/MAPL_GenericCplComp.F90 index e5965be04f93..71d7e4bfc28d 100644 --- a/MAPL_Base/MAPL_GenericCplComp.F90 +++ b/MAPL_Base/MAPL_GenericCplComp.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_Generic.h" #include "unused_dummy.H" @@ -25,6 +24,7 @@ module MAPL_GenericCplCompMod use MAPL_BaseMod use MAPL_ConstantsMod use MAPL_IOMod + use MAPL_CommsMod use MAPL_ProfMod use MAPL_SunMod use MAPL_VarSpecMod @@ -37,6 +37,7 @@ module MAPL_GenericCplCompMod public GenericCplSetServices public MAPL_CplCompSetVarSpecs + public MAPL_CplCompSetAlarm !EOP @@ -51,6 +52,7 @@ module MAPL_GenericCplCompMod ! These are done in set services type (ESMF_Config) :: CF logical :: ACTIVE + type (ESMF_Alarm), pointer :: TIME2CPL_ALARM => null() character(LEN=ESMF_MAXSTR) :: NAME type (MAPL_VarSpec), pointer :: SRC_SPEC(:) => null() type (MAPL_VarSpec), pointer :: DST_SPEC(:) => null() @@ -142,6 +144,14 @@ subroutine GenericCplSetServices ( CC, RC ) rc=STATUS ) _VERIFY(STATUS) +!ALT: Add these 2 IO methods to facilitate transparent checkpointing +! to support monthly averages + call ESMF_CplCompSetEntryPoint ( CC, ESMF_METHOD_READRESTART, ReadRestart, & + rc=STATUS ) + _VERIFY(STATUS) + call ESMF_CplCompSetEntryPoint ( CC, ESMF_METHOD_WRITERESTART, WriteRestart, & + rc=STATUS ) + _VERIFY(STATUS) ! Put the inherited configuration in the internal state ! ----------------------------------------------------- @@ -367,46 +377,50 @@ subroutine Initialize(CC, SRC, DST, CLOCK, RC) rTime = TM0 + TOFF - STATE%TIME_TO_COUPLE(J) = ESMF_AlarmCreate(NAME='TIME2COUPLE_' // trim(COMP_NAME) & - // '_' // trim(NAME), & - clock = CLOCK, & - ringInterval = TCPL, & - ringTime = rTime, & - sticky = .false., & - rc=STATUS ) - _VERIFY(STATUS) - - if(rTime == currTime) then - call ESMF_AlarmRingerOn(STATE%TIME_TO_COUPLE(J), rc=status); _VERIFY(STATUS) - end if + if (associated(STATE%TIME2CPL_ALARM)) then + STATE%TIME_TO_COUPLE(J) = STATE%TIME2CPL_ALARM + STATE%TIME_TO_CLEAR(J) = STATE%TIME2CPL_ALARM + else + STATE%TIME_TO_COUPLE(J) = ESMF_AlarmCreate(NAME='TIME2COUPLE_' // trim(COMP_NAME) & + // '_' // trim(NAME), & + clock = CLOCK, & + ringInterval = TCPL, & + ringTime = rTime, & + sticky = .false., & + rc=STATUS ) + _VERIFY(STATUS) + if(rTime == currTime) then + call ESMF_AlarmRingerOn(STATE%TIME_TO_COUPLE(J), rc=status); _VERIFY(STATUS) + end if ! initalize CLEAR ALARM from destination properties !-------------------------------------------------- - call ESMF_TimeIntervalSet(TCLR, S=STATE%CLEAR_INTERVAL(J), & - calendar=cal, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeIntervalSet(TCLR, S=STATE%CLEAR_INTERVAL(J), & + calendar=cal, RC=STATUS) + _VERIFY(STATUS) - if (TCLR < TS) TCLR = TS + if (TCLR < TS) TCLR = TS - rTime = TM0 + TOFF - TCLR + rTime = TM0 + TOFF - TCLR - do while (rTime < currTime) - rTime = rTime + TCPL - end do + do while (rTime < currTime) + rTime = rTime + TCPL + end do - STATE%TIME_TO_CLEAR(J) = ESMF_AlarmCreate(NAME='TIME2CLEAR_' // trim(COMP_NAME) & - // '_' // trim(NAME), & - clock = CLOCK, & - ringInterval = TCPL, & - ringTime = rTime, & - sticky = .false., & - rc=STATUS ) - _VERIFY(STATUS) + STATE%TIME_TO_CLEAR(J) = ESMF_AlarmCreate(NAME='TIME2CLEAR_' // trim(COMP_NAME) & + // '_' // trim(NAME), & + clock = CLOCK, & + ringInterval = TCPL, & + ringTime = rTime, & + sticky = .false., & + rc=STATUS ) + _VERIFY(STATUS) - if(rTime == currTime) then - call ESMF_AlarmRingerOn(STATE%TIME_TO_CLEAR(J), rc=status); _VERIFY(STATUS) + if(rTime == currTime) then + call ESMF_AlarmRingerOn(STATE%TIME_TO_CLEAR(J), rc=status); _VERIFY(STATUS) + end if end if ! Get info from the SRC spec @@ -815,8 +829,10 @@ subroutine ZERO_CLEAR_COUNT(STATE, RC) _VERIFY(STATUS) if (RINGING) then - call ESMF_AlarmRingerOff(STATE%TIME_TO_CLEAR(J), RC=STATUS) - _VERIFY(STATUS) + if(.not.associated(STATE%TIME2CPL_ALARM)) then + call ESMF_AlarmRingerOff(STATE%TIME_TO_CLEAR(J), RC=STATUS) + _VERIFY(STATUS) + end if DIMS = STATE%ACCUM_RANK(J) @@ -914,8 +930,10 @@ subroutine COUPLE(SRC, STATE, RC) if (RINGING) then - call ESMF_AlarmRingerOff(STATE%TIME_TO_COUPLE(J), RC=STATUS) - _VERIFY(STATUS) + if(.not.associated(STATE%TIME2CPL_ALARM)) then + call ESMF_AlarmRingerOff(STATE%TIME_TO_COUPLE(J), RC=STATUS) + _VERIFY(STATUS) + end if call MAPL_VarSpecGet(STATE%DST_SPEC(J), SHORT_NAME=NAME, RC=STATUS) _VERIFY(STATUS) @@ -1103,4 +1121,437 @@ subroutine Finalize(CC, SRC, DST, CLOCK, RC) call write_parallel('STUBBED in CPL finalize') _RETURN(ESMF_SUCCESS) end subroutine Finalize + + subroutine ReadRestart(CC, SRC, DST, CLOCK, RC) + +! !ARGUMENTS: + + type (ESMF_CplComp) :: CC + type (ESMF_State) :: SRC + type (ESMF_State) :: DST + type (ESMF_Clock) :: CLOCK + integer, intent( OUT) :: RC + +!EOPI +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + character(len=ESMF_MAXSTR) :: COMP_NAME + integer :: STATUS + +! Locals + + type (MAPL_GenericCplState), pointer :: STATE + type (MAPL_GenericCplWrap ) :: WRAP + type(ESMF_VM) :: VM + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + character(len=ESMF_MAXSTR) :: name + character(len=ESMF_MAXSTR) :: filename + logical :: file_exists + logical :: am_i_root + integer :: unit + integer :: n_vars + integer :: n_count + integer :: n_undefs + integer :: rank + integer :: i + integer :: dims + integer, pointer :: mask(:) => null() + real, allocatable :: buf1(:), buf2(:,:), buf3(:,:,:) + real, pointer :: ptr1(:), ptr2(:,:), ptr3(:,:,:) + +! Begin... + +! Get the target components name and set-up traceback handle. +! ----------------------------------------------------------- + + IAm = "MAPL_GenericCplComReadRestart" + call ESMF_CplCompGet( CC, NAME=COMP_NAME, RC=STATUS ) + _VERIFY(STATUS) + Iam = trim(COMP_NAME) // Iam + +! Retrieve the pointer to the internal state. It comes in a wrapper. +! ------------------------------------------------------------------ + + call ESMF_CplCompGetInternalState ( CC, WRAP, STATUS ) + _VERIFY(STATUS) + + STATE => WRAP%INTERNAL_STATE + + +!ALT remove this line when done + call write_parallel('STUBBED in CPL ReadRestart') +!ALT: Uncomment when done +!strategy +!root tries to open the restart (or inquire) +!if the file is there +! read the restart: +!================== +! call ESMF_CplCompGet(CC, vm=vm, name=name, rc=status) +! _VERIFY(STATUS) + +! filename = trim(name) // '_rst' ! following Andrea's suggestion + + call ESMF_CplCompGet(CC, vm=vm, rc=status) + _VERIFY(STATUS) + filename = trim(state%name) // '_rst' ! following Andrea's suggestion + am_i_root = MAPL_AM_I_ROOT(vm) + if (am_i_root) then + ! check if file exists + inquire(file=filename, exist=file_exists) + end if + + call MAPL_CommsBcast(vm, file_exists, n=1, ROOT=MAPL_Root, rc=status) + _VERIFY(status) + + if (file_exists) then + !ALT: ideally, we should check the monthly alarm: read only when not ringing. + ! read metadata: grid info, number of vars + unit=0 ! just to initialize + if (am_i_root) then + UNIT = GETFILE(filename, rc=status) + _VERIFY(status) + read(unit) n_vars + _ASSERT(size(state%src_spec) == n_vars, "Number of variables on the restart does not agree with spec") + end if + + ! for each var + n_vars = size(state%src_spec) + do i = 1, n_vars + ! varname we can get from query SHORT_NAME in state%src_spec(i) + call MAPL_VarSpecGet(state%src_spec(i), SHORT_NAME=name, rc=status) + _VERIFY(status) + call ESMF_StateGet(SRC, name, field=field, rc=status) + _VERIFY(status) + call ESMF_FieldGet(field, grid=grid, rc=status) + _VERIFY(status) + + rank = state%accum_rank(i) + call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) + _VERIFY(STATUS) + mask => null() + if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then + call MAPL_TileMaskGet(grid, mask, rc=status) + _VERIFY(STATUS) + end if + ! ALT note: calling a procedure with optional argument, and passing NULL pointer to indicate "absent", needs ifort16 or newer + + if (am_i_root) then + read(unit) n_count + end if + call MAPL_CommsBcast(vm, n_count, n=1, ROOT=MAPL_Root, rc=status) + _VERIFY(status) + state%accum_count(i) = n_count + + if (am_i_root) then + read(unit) n_undefs + end if + call MAPL_CommsBcast(vm, n_undefs, n=1, ROOT=MAPL_Root, rc=status) + _VERIFY(status) + + select case(rank) + case (3) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr3, RC=status) + _VERIFY(status) + + call MAPL_VarRead(unit, grid, ptr3, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf3(size(ptr3,1),size(ptr3,2),size(ptr3,3)), stat=status) + _VERIFY(STATUS) + call MAPL_VarRead(unit, grid, buf3, rc=status) + _VERIFY(STATUS) + if (.not. associated(state%array_count(i)%ptr3c)) then + allocate(state%array_count(i)%ptr3c(size(ptr3,1),size(ptr3,2),size(ptr3,3)), stat=status) + _VERIFY(STATUS) + end if + state%array_count(i)%ptr3c = buf3 + deallocate(buf3) + end if + case (2) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr2, RC=status) + _VERIFY(status) + + call MAPL_VarRead(unit, grid, ptr2, mask=mask, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf2(size(ptr2,1),size(ptr2,2)), stat=status) + _VERIFY(STATUS) + call MAPL_VarRead(unit, grid, buf2, mask=mask, rc=status) + _VERIFY(STATUS) + if (.not. associated(state%array_count(i)%ptr2c)) then + allocate(state%array_count(i)%ptr2c(size(ptr2,1),size(ptr2,2)), stat=status) + _VERIFY(STATUS) + end if + state%array_count(i)%ptr2c = buf2 + deallocate(buf2) + end if + case (1) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr1, RC=status) + _VERIFY(status) + + call MAPL_VarRead(unit, grid, ptr1, mask=mask, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf1(size(ptr1,1)), stat=status) + _VERIFY(STATUS) + call MAPL_VarRead(unit, grid, buf1, mask=mask, rc=status) + _VERIFY(STATUS) + if (.not. associated(state%array_count(i)%ptr1c)) then + allocate(state%array_count(i)%ptr1c(size(ptr1,1)), stat=status) + _VERIFY(STATUS) + end if + state%array_count(i)%ptr1c = buf1 + deallocate(buf1) + end if + case default + _ASSERT(.false., "Unsupported rank") + end select + if(associated(mask)) deallocate(mask) + end do + + if (am_i_root) call Free_File(unit = UNIT, rc=STATUS) + + else + RC = ESMF_RC_FILE_READ + return + end if + + _RETURN(ESMF_SUCCESS) + end subroutine ReadRestart + + subroutine WriteRestart(CC, SRC, DST, CLOCK, RC) + +! !ARGUMENTS: + + type (ESMF_CplComp) :: CC + type (ESMF_State) :: SRC + type (ESMF_State) :: DST + type (ESMF_Clock) :: CLOCK + integer, intent( OUT) :: RC + +!EOPI +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + character(len=ESMF_MAXSTR) :: COMP_NAME + integer :: STATUS + +! Locals + + type (MAPL_GenericCplState), pointer :: STATE + type (MAPL_GenericCplWrap ) :: WRAP + type(ESMF_VM) :: VM + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + character(len=ESMF_MAXSTR) :: name + character(len=ESMF_MAXSTR) :: filename + logical :: am_i_root + logical :: local_undefs + integer :: unit + integer :: n_vars + integer :: n_count + integer :: n_undefs + integer :: rank + integer :: i + integer :: dims + integer :: have_undefs + integer, pointer :: mask(:) => null() + real, allocatable :: buf1(:), buf2(:,:), buf3(:,:,:) + real, pointer :: ptr1(:), ptr2(:,:), ptr3(:,:,:) + +! Begin... + +! Get the target components name and set-up traceback handle. +! ----------------------------------------------------------- + + IAm = "MAPL_GenericCplComWriteRestart" + call ESMF_CplCompGet( CC, NAME=COMP_NAME, RC=STATUS ) + _VERIFY(STATUS) + Iam = trim(COMP_NAME) // Iam + +! Retrieve the pointer to the internal state. It comes in a wrapper. +! ------------------------------------------------------------------ + + call ESMF_CplCompGetInternalState ( CC, WRAP, STATUS ) + _VERIFY(STATUS) + + STATE => WRAP%INTERNAL_STATE + + call ESMF_CplCompGet(CC, vm=vm, rc=status) + _VERIFY(STATUS) + + filename = trim(state%name) // '_chk' ! following Andrea's suggestion + am_i_root = MAPL_AM_I_ROOT(vm) + + unit=0 ! just to initialize + n_vars = size(state%src_spec) + if (am_i_root) then + UNIT = GETFILE(filename, rc=status) + _VERIFY(status) + write(unit) n_vars + end if + + ! for each var + do i = 1, n_vars + ! varname we can get from query SHORT_NAME in state%src_spec(i) + call MAPL_VarSpecGet(state%src_spec(i), SHORT_NAME=name, rc=status) + _VERIFY(status) + call ESMF_StateGet(SRC, name, field=field, rc=status) + _VERIFY(status) + call ESMF_FieldGet(field, grid=grid, rc=status) + _VERIFY(status) + + rank = state%accum_rank(i) + call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) + _VERIFY(STATUS) + mask => null() + if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then + call MAPL_TileMaskGet(grid, mask, rc=status) + _VERIFY(STATUS) + end if + + !we need to get the MAX n_count + call MAPL_CommsAllReduceMax(vm, sendbuf=state%accum_count(i), & + recvbuf=n_count, cnt=1, RC=status) + _VERIFY(status) + if (am_i_root) then + write(unit) n_count + end if + select case (rank) + case(1) + local_undefs = associated(state%array_count(i)%ptr1c) + case(2) + local_undefs = associated(state%array_count(i)%ptr2c) + case(3) + local_undefs = associated(state%array_count(i)%ptr3c) + case default + _ASSERT(.false., "Unsupported rank") + end select + have_undefs = 0 + n_undefs = 0 + if (local_undefs) have_undefs = 1 + call MAPL_CommsAllReduceMax(vm, sendbuf=have_undefs, & + recvbuf=n_undefs, cnt=1, RC=status) + _VERIFY(status) + if (am_i_root) then + write(unit) n_undefs + end if + + select case(rank) + case (3) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr3, RC=status) + _VERIFY(status) + + call MAPL_VarWrite(unit, grid, ptr3, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf3(size(ptr3,1),size(ptr3,2),size(ptr3,3)), stat=status) + _VERIFY(STATUS) + if (associated(state%array_count(i)%ptr3c)) then + buf3 = state%array_count(i)%ptr3c + else + buf3 = state%accum_count(i) + end if + call MAPL_VarWrite(unit, grid, buf3, rc=status) + _VERIFY(STATUS) + deallocate(buf3) + end if + case (2) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr2, RC=status) + _VERIFY(status) + + call MAPL_VarWrite(unit, grid, ptr2, mask=mask, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf2(size(ptr2,1),size(ptr2,2)), stat=status) + _VERIFY(STATUS) + if (associated(state%array_count(i)%ptr2c)) then + buf2 = state%array_count(i)%ptr2c + else + buf2 = state%accum_count(i) + end if + call MAPL_VarWrite(unit, grid, buf2, mask=mask, rc=status) + _VERIFY(STATUS) + deallocate(buf2) + end if + case (1) + call ESMF_LocalArrayGet(STATE%ACCUMULATORS(i), & + farrayPtr=ptr1, RC=status) + _VERIFY(status) + + call MAPL_VarWrite(unit, grid, ptr1, mask=mask, rc=status) + _VERIFY(STATUS) + if (n_undefs /=0) then + allocate(buf1(size(ptr1,1)), stat=status) + _VERIFY(STATUS) + if (associated(state%array_count(i)%ptr1c)) then + buf1 = state%array_count(i)%ptr1c + else + buf1 = state%accum_count(i) + end if + call MAPL_VarWrite(unit, grid, buf1, mask=mask, rc=status) + _VERIFY(STATUS) + deallocate(buf1) + end if + case default + _ASSERT(.false.," Unsupported rank") + end select + if(associated(mask)) deallocate(mask) + end do + + if(am_i_root) call Free_File(unit = UNIT, rc=STATUS) + + + _RETURN(ESMF_SUCCESS) + end subroutine WriteRestart + + subroutine MAPL_CplCompSetAlarm ( CC, ALARM, RC ) + type (ESMF_CplComp ), intent(INOUT) :: CC + type (ESMF_Alarm), target, intent(IN ) :: ALARM + integer, optional, intent( OUT) :: RC + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + character(len=ESMF_MAXSTR) :: COMP_NAME + integer :: STATUS + +! Locals + + type (MAPL_GenericCplState), pointer :: STATE + type (MAPL_GenericCplWrap ) :: WRAP + + +! Begin... + +! Get this instance's name and set-up traceback handle. +! ----------------------------------------------------- + + call ESMF_CplCompGet( CC, name=COMP_NAME, RC=STATUS ) + _VERIFY(STATUS) + Iam = trim(COMP_NAME) // "MAPL_CplCompSetAlarm" + +! Retrieve the pointer to the internal state. It comes in a wrapper. +! ------------------------------------------------------------------ + + call ESMF_CplCompGetInternalState ( CC, WRAP, STATUS ) + _VERIFY(STATUS) + + STATE => WRAP%INTERNAL_STATE + + if (.not.associated(STATE%TIME2CPL_ALARM)) then + STATE%TIME2CPL_ALARM => ALARM + else + _ASSERT(.false., "Alarm is already associated! Cannot set it again!") + end if + _RETURN(ESMF_SUCCESS) + end subroutine MAPL_CplCompSetAlarm + end module MAPL_GenericCplCompMod diff --git a/MAPL_Base/MAPL_GetLatLonCoord.F90 b/MAPL_Base/MAPL_GetLatLonCoord.F90 index 3eb40f370ddc..598fc0e0872e 100644 --- a/MAPL_Base/MAPL_GetLatLonCoord.F90 +++ b/MAPL_Base/MAPL_GetLatLonCoord.F90 @@ -39,7 +39,6 @@ subroutine MAPL_GetLatLonCoord_REAL64(grid,dim,x,rc) type(ESMF_DeLayout) :: layout type(ESMF_VM) :: vm integer :: status - character(len=ESMF_MAXSTR) :: Iam = "MAPL_GetLatLonCoord_REAL64" call ESMF_GridGetCoord (grid, coordDim=dim, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & @@ -87,7 +86,6 @@ subroutine MAPL_GetLatLonCoord_REAL32(grid,dim,x,rc) type(ESMF_DeLayout) :: layout type(ESMF_VM) :: vm integer :: status - character(len=ESMF_MAXSTR) :: Iam = "MAPL_GetLatLonCoord_REAL32" call ESMF_GridGetCoord (grid, coordDim=dim, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & diff --git a/MAPL_Base/MAPL_Hash.F90 b/MAPL_Base/MAPL_Hash.F90 index 174cf495932e..4fb326a73567 100644 --- a/MAPL_Base/MAPL_Hash.F90 +++ b/MAPL_Base/MAPL_Hash.F90 @@ -3,7 +3,6 @@ #include "MAPL_ErrLog.h" -! $Id$ !============================================================================= !BOP diff --git a/MAPL_Base/MAPL_HeapMod.F90 b/MAPL_Base/MAPL_HeapMod.F90 index c81cd8beefdf..15bd36c45872 100644 --- a/MAPL_Base/MAPL_HeapMod.F90 +++ b/MAPL_Base/MAPL_HeapMod.F90 @@ -1,5 +1,4 @@ -! $Id$ #include "MAPL_ErrLog.h" #define ADDRS_POSITION 1 diff --git a/MAPL_Base/MAPL_HistoryCollection.F90 b/MAPL_Base/MAPL_HistoryCollection.F90 index 519eaf3dc1ff..6a9ef108079a 100644 --- a/MAPL_Base/MAPL_HistoryCollection.F90 +++ b/MAPL_Base/MAPL_HistoryCollection.F90 @@ -66,6 +66,8 @@ module MAPL_HistoryCollectionMod integer :: Psize integer :: tm logical :: ForceOffsetZero + logical :: monthly + logical :: partial = .false. ! Adding Arithemtic Field Rewrite character(len=ESMF_MAXSTR),pointer :: tmpfields(:) => null() logical, pointer :: ReWrite(:) => null() diff --git a/MAPL_Base/MAPL_HistoryGridComp.F90 b/MAPL_Base/MAPL_HistoryGridComp.F90 index b7b0d2975fc8..c6463b9f99f4 100644 --- a/MAPL_Base/MAPL_HistoryGridComp.F90 +++ b/MAPL_Base/MAPL_HistoryGridComp.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_Generic.h" #include "unused_dummy.H" @@ -140,7 +139,6 @@ subroutine SetServices ( gc, rc ) integer, optional :: rc ! return code integer :: status - character(len=ESMF_MAXSTR) :: IAm="History:SetServices" type (HISTORY_wrap) :: wrap type (HISTORY_STATE), pointer :: internal_state @@ -260,7 +258,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! EOP integer :: status - character(len=ESMF_MAXSTR) :: IAm="History:Initalize" logical :: errorFound logical :: found @@ -361,6 +358,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) logical :: isPresent real :: lvl + integer :: mntly integer :: unitr, unitw integer :: tm,resolution(2) logical :: match, contLine @@ -376,14 +374,13 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Async cfio option type(MAPL_Communicators) :: mapl_comm - logical :: Async, doAsync + logical :: doAsync ! Single colum flag used to set different defalut for TM integer :: snglcol integer :: tm_default ! variable for vector handling - logical :: vectorDone integer :: idx, nvec character(len=ESMF_MAXSTR) :: f1copy, f3copy character(len=ESMF_MAXSTR), pointer :: vectorList(:,:) => null() @@ -413,7 +410,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) character(len=:), pointer :: key type(StringFieldSetMapIterator) :: field_set_iter character(ESMF_MAXSTR) :: field_set_name - integer :: nfields,collection_id + integer :: collection_id ! Begin !------ @@ -664,6 +661,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _VERIFY(STATUS) allocate( Vvarn(nlist), stat=STATUS) _VERIFY(STATUS) + allocate(INTSTATE%STAMPOFFSET(nlist), stat=status) + _VERIFY(STATUS) ! We are parsing HISTORY config file to split each collection into separate RC ! ---------------------------------------------------------------------------- @@ -737,6 +736,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%disabled = .false. end if + list(n)%monthly = .false. + cfg = ESMF_ConfigCreate(rc=STATUS) _VERIFY(STATUS) @@ -756,6 +757,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label=trim(string) // 'descr:' ,rc=status ) _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg, mntly, default=0, & + label=trim(string) // 'monthly:',rc=status ) + _VERIFY(STATUS) + list(n)%monthly = (mntly /= 0) call ESMF_ConfigGetAttribute ( cfg, list(n)%frequency, default=060000, & label=trim(string) // 'frequency:',rc=status ) _VERIFY(STATUS) @@ -1152,6 +1157,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) REF_TIME(4) = list(n)%ref_time/10000 REF_TIME(5) = mod(list(n)%ref_time,10000)/100 REF_TIME(6) = mod(list(n)%ref_time,100) + + !ALT if monthly, modify ref_time(4:6)=0 + if (list(n)%monthly) REF_TIME(4:6) = 0 call ESMF_TimeSet( RefTime, YY = REF_TIME(1), & MM = REF_TIME(2), & @@ -1160,6 +1168,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) M = REF_TIME(5), & S = REF_TIME(6), calendar=cal, rc=rc ) + ! ALT if monthly, set interval "Frequncy" to 1 month + ! also in this case sec should be set to non-zero sec = MAPL_nsecf( list(n)%frequency ) call ESMF_TimeIntervalSet( Frequency, S=sec, calendar=cal, rc=status ) ; _VERIFY(STATUS) RingTime = RefTime @@ -1179,11 +1189,21 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) endif _VERIFY(STATUS) - + + !ALT if monthly overwrite duration and frequency + if (list(n)%monthly) then + list(n)%duration = 1 !ALT simply non-zero + end if if( list(n)%duration.ne.0 ) then - sec = MAPL_nsecf( list(n)%duration ) - call ESMF_TimeIntervalSet( Frequency, S=sec, calendar=cal, rc=status ) ; _VERIFY(STATUS) - RingTime = RefTime + IntState%StampOffset(n) + if (.not.list(n)%monthly) then + sec = MAPL_nsecf( list(n)%duration ) + call ESMF_TimeIntervalSet( Frequency, S=sec, calendar=cal, rc=status ) ; _VERIFY(STATUS) + RingTime = RefTime + else + !ALT keep the values from above + ! and for debugging print + call WRITE_PARALLEL("DEBUG: monthly averaging is active for collection "//trim(list(n)%collection)) + end if if (RingTime < currTime) then RingTime = RingTime + (INT((currTime - RingTime)/frequency)+1)*frequency endif @@ -1193,6 +1213,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) endif _VERIFY(STATUS) + if (list(n)%monthly .and. (currTime == RingTime)) then + call ESMF_AlarmRingerOn( list(n)%his_alarm,rc=status ) + _VERIFY(STATUS) + end if + else ! this alarm should never ring, but it is checked if ringing list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, enabled=.false., & @@ -1227,7 +1252,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) 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 + ! better yet, create it like this one in the first place + call ESMF_AlarmDestroy(list(n)%his_alarm) + list(n)%his_alarm = list(n)%mon_alarm + intState%stampOffset(n) = Frequency ! we go to the beginning of the month + end if + ! End Alarm based on end_date and end_time ! ---------------------------------------- if( list(n)%end_date.ne.-999 .and. list(n)%end_time.ne.-999 ) then @@ -1540,6 +1573,23 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _ASSERT(.not. errorFound,'needs informative message') + allocate(INTSTATE%AVERAGE (nlist), stat=status) + _VERIFY(STATUS) + + IntState%average = .false. + do n=1, nlist + if (list(n)%disabled) cycle + if(list(n)%mode == "instantaneous" .or. list(n)%ForceOffsetZero) then + sec = 0 + else + IntState%average(n) = .true. + sec = MAPL_nsecf(list(n)%acc_interval) / 2 + if(list(n)%monthly) cycle + endif + call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, rc=status ) + _VERIFY(STATUS) + end do + nactual = npes if (.not. disableSubVmChecks) then allocate(allPes(npes), stat=status) @@ -2155,13 +2205,13 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! create CC if (nactual == npes) then IntState%CCS(n) = ESMF_CplCompCreate ( & - NAME = 'History', & + NAME = list(n)%collection, & contextFlag = ESMF_CONTEXT_PARENT_VM, & RC=STATUS ) _VERIFY(STATUS) else IntState%CCS(n) = ESMF_CplCompCreate ( & - NAME = 'History', & + NAME = list(n)%collection, & petList = list(n)%peAve, & contextFlag = ESMF_CONTEXT_OWN_VM, & RC=STATUS ) @@ -2178,6 +2228,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) INTSTATE%DSTS(n)%SPEC,RC=STATUS) _VERIFY(STATUS) + if (list(n)%monthly) then + call MAPL_CplCompSetAlarm(IntState%CCS(n), & + list(n)%his_alarm, RC=STATUS) + _VERIFY(STATUS) + end if + ! CCInitialize call ESMF_CplCompInitialize (INTSTATE%CCS(n), & importState=INTSTATE%CIM(n), & @@ -2185,6 +2241,23 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) clock=CLOCK, & userRC=STATUS) _VERIFY(STATUS) + + if(list(n)%monthly) then + ! check if alarm is ringing + if (.not. ESMF_AlarmIsRinging ( list(n)%his_alarm )) then + call ESMF_CplCompReadRestart (INTSTATE%CCS(n), & + importState=INTSTATE%CIM(n), & + exportState=INTSTATE%GIM(n), & + clock=CLOCK, & + userRC=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 end do @@ -2679,17 +2752,14 @@ subroutine Run ( gc, import, export, clock, rc ) type(ESMF_State) :: state_out integer :: nymd, nhms character(len=ESMF_MAXSTR) :: DateStamp - integer :: n1, n2, nn, CollBlock, scount + integer :: CollBlock type(MAPL_Communicators) :: mapl_Comm - integer :: nNodes,RootRank - logical :: PrePost_ ! variables for "backwards" mode logical :: fwd logical, allocatable :: Ignore(:) ! ErrLog vars - character(len=ESMF_MAXSTR) :: IAm="HistoryRun" integer :: status !============================================================================= @@ -2899,6 +2969,15 @@ subroutine Run ( gc, import, export, clock, rc ) nymd=nymd, nhms=nhms, stat=status ) ! here is where we get the actual filename of file we will write _VERIFY(STATUS) + if(list(n)%monthly .and. list(n)%partial) then + filename(n)=trim(filename(n)) // '-partial' + list(n)%currentFile = filename(n) + end if + + if( NewSeg) then + list(n)%partial = .false. + endif + if( list(n)%unit.eq.0 ) then if (list(n)%format == 'CFIO') then call list(n)%mNewCFIO%modifyTime(oClients=o_Clients,rc=status) @@ -3067,14 +3146,12 @@ subroutine Finalize ( gc, import, export, clock, rc ) ! = 0 all is well ! otherwise, error - character(len=ESMF_MAXSTR) :: IAm="Finalize" integer :: status type(HistoryCollection), pointer :: list(:) type(HISTORY_wrap) :: wrap type (HISTORY_STATE), pointer :: IntState integer :: nlist, n type (MAPL_MetaComp), pointer :: GENSTATE - type(MAPL_Communicators) :: mapl_Comm ! Begin... @@ -3107,6 +3184,19 @@ subroutine Finalize ( gc, import, export, clock, rc ) ELSE if( list(n)%unit.ne.0 ) call FREE_FILE( list(n)%unit ) END if + if(list(n)%monthly) then + !ALT need some logic if alarm if not ringing + if (.not. ESMF_AlarmIsRinging ( list(n)%his_alarm )) then + if (.not. list(n)%partial) then + call ESMF_CplCompWriteRestart (INTSTATE%CCS(n), & + importState=INTSTATE%CIM(n), & + exportState=INTSTATE%GIM(n), & + clock=CLOCK, & + userRC=STATUS) + _VERIFY(STATUS) + end if + end if + end if enddo #if 0 @@ -3176,7 +3266,6 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid 'JUL','AUG','SEP','OCT','NOV','DEC'/ integer :: unit,nfield - character(len=ESMF_MAXSTR) :: IAm="MAPL_GradsCtlWrite" integer :: k,m,rank,status integer :: year,month,day,hour,minute real(kind=REAL64) LONBEG,DLON @@ -3447,7 +3536,6 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) character*2 second integer :: STATUS - character(len=ESMF_MAXSTR) :: Iam="get_DateStamp" equivalence ( string(01),TimeString ) equivalence ( string(01),year ) @@ -3514,7 +3602,6 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, integer, optional , intent( OUT) :: RC integer :: STATUS - character(len=ESMF_MAXSTR), parameter :: Iam='RegridTransform' integer :: L, LM integer :: LL, LU @@ -3646,7 +3733,6 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ integer, optional , intent( OUT) :: RC integer :: STATUS - character(len=ESMF_MAXSTR), parameter :: Iam='RegridTransformT2G2G' integer :: L, LM, K, KM integer :: I @@ -3868,7 +3954,6 @@ subroutine RegridTransformT2G(STATE_IN, XFORM, STATE_OUT, LS_OUT, NTILES_OUT, RC integer, optional , intent( OUT) :: RC integer :: STATUS - character(len=ESMF_MAXSTR), parameter :: Iam = "RegridTransformT2G" integer :: I, L, K, LM, KM integer :: rank_in @@ -4144,7 +4229,6 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & integer:: i,j,m,k,status,largest_rank,iRepField,ivLoc logical :: ifound_vloc - character(len=ESMF_MAXSTR) :: Iam='MAPL_SetExpression' character(len=ESMF_MAXSTR) :: tmpList character(len=ESMF_MAXSTR) :: VarName integer :: idx @@ -4417,7 +4501,6 @@ subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) integer, optional, intent(out) :: rc ! Local variables: - character(len=ESMF_MAXSTR) :: Iam='MAPL_RunExpression' character(len=ESMF_MAXSTR) :: fname,fexpr integer:: m,STATUS type(ESMF_Field) :: field @@ -4443,7 +4526,6 @@ subroutine MAPL_StateDestroy(State, RC) integer, optional,intent( out) :: rc ! Local variables: - character(len=ESMF_MAXSTR) :: Iam='MAPL_StateDestroy' integer :: STATUS type(ESMF_Field) :: field @@ -4505,7 +4587,6 @@ subroutine MAPL_StateGet(state,name,field,rc) type(ESMF_Field), intent(inout) :: field integer, optional, intent(out ) :: rc - character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_StateGet' integer :: status character(len=ESMF_MAXSTR) :: bundlename, fieldname type(ESMF_FieldBundle) :: bundle @@ -4517,11 +4598,12 @@ subroutine MAPL_StateGet(state,name,field,rc) bundlename = name(:i-1) fieldname = name(i+1:) call ESMF_StateGet(state,trim(bundlename),bundle,rc=status) - _VERIFY(STATUS) + _ASSERT(status==ESMF_SUCCESS,'Bundle '//trim(bundlename)//' not found') call ESMF_FieldBundleGet(bundle,trim(fieldname),field=field,rc=status) - _VERIFY(STATUS) + _ASSERT(status==ESMF_SUCCESS,'Field '//trim(fieldname)//' not found') else call ESMF_StateGet(state,trim(name),field,rc=status) + _ASSERT(status==ESMF_SUCCESS,'Field '//trim(name)//' not found') _VERIFY(STATUS) end if diff --git a/MAPL_Base/MAPL_IO.F90 b/MAPL_Base/MAPL_IO.F90 index 0e3454896272..1d864b31394b 100644 --- a/MAPL_Base/MAPL_IO.F90 +++ b/MAPL_Base/MAPL_IO.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" #define DEALOC_(A) if(associated(A))then;if(MAPL_ShmInitialized)then;call MAPL_SyncSharedMemory(rc=STATUS);call MAPL_DeAllocNodeArray(A,rc=STATUS);else;deallocate(A,stat=STATUS);endif;_VERIFY(STATUS);NULLIFY(A);endif @@ -2819,7 +2818,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients integer :: J,K type (ESMF_DistGrid) :: distGrid type (LocalMemReference) :: lMemRef - integer :: request_id, size_1d + integer :: size_1d call ESMF_FieldGet(field, grid=grid, rc=status) @@ -5177,7 +5176,7 @@ subroutine MAPL_VarWriteNCpar_R4_3d(formatter, name, A, ARRDES, oClients, RC) integer :: status integer :: l - integer :: i1, j1, in, jn, global_dim(3), request_id + integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref if (arrdes%write_restart_by_oserver) then @@ -5240,7 +5239,7 @@ subroutine MAPL_VarWriteNCpar_R8_3d(formatter, name, A, ARRDES, oClients, RC) integer :: l - integer :: i1, j1, in, jn, global_dim(3), request_id + integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref @@ -5316,7 +5315,7 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, oClients, R logical :: AM_WRITER type (ArrayReference) :: ref - integer :: i1, j1, in, jn, global_dim(3), request_id + integer :: i1, j1, in, jn, global_dim(3) if (present(arrdes)) then if(arrdes%write_restart_by_oserver) then @@ -6903,7 +6902,7 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, oClients, R logical :: AM_WRITER type (ArrayReference) :: ref - integer :: i1, j1, in, jn, global_dim(3), request_id + integer :: i1, j1, in, jn, global_dim(3) if (present(arrdes)) then if( arrdes%write_restart_by_oserver) then @@ -7069,7 +7068,6 @@ subroutine MAPL_VarReadNCpar_R8_2d(formatter, name, A, ARRDES, lev, RC) integer :: IM_WORLD integer :: JM_WORLD integer :: status - character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R8_2d' real(kind=ESMF_KIND_R8), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x @@ -7314,7 +7312,6 @@ subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, type (ESMF_Field) :: field integer :: status integer :: I, K - character(len=ESMF_MAXSTR) :: IAm='MAPL_StateVarReadNCPar' integer :: J, ITEMCOUNT type (ESMF_StateItem_Flag), pointer :: ITEMTYPES(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES(:) @@ -8797,7 +8794,6 @@ subroutine MAPL_IOCountNonDimVars(cf,nvars,rc) integer, intent(out) :: nvars integer, intent(out), optional :: rc - integer :: status type(StringVariableMap), pointer :: vars type(StringVariableMapIterator) :: iter type(StringIntegerMap), pointer :: dims @@ -8826,7 +8822,6 @@ function MAPL_IOGetNonDimVars(cf,rc) result(nondim_vars) type(FileMetadata), intent(inout) :: cf integer, intent(out), optional :: rc - integer :: status type(StringVector) :: nondim_vars type(StringVariableMap), pointer :: vars type(StringVariableMapIterator) :: iter diff --git a/MAPL_Base/MAPL_IdentityRegridder.F90 b/MAPL_Base/MAPL_IdentityRegridder.F90 index 191ac0a78ac1..09647848b013 100644 --- a/MAPL_Base/MAPL_IdentityRegridder.F90 +++ b/MAPL_Base/MAPL_IdentityRegridder.F90 @@ -106,6 +106,7 @@ subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) character(len=*), parameter :: Iam = MOD_NAME//'regrid_vector_3d_real32' _UNUSED_DUMMY(this) + _UNUSED_DUMMY(rotate) u_out = u_in v_out = v_in @@ -130,6 +131,7 @@ subroutine regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) character(len=*), parameter :: Iam = MOD_NAME//'regrid_vector_3d_real32' _UNUSED_DUMMY(this) + _UNUSED_DUMMY(rotate) _ASSERT(size(u_in,3) == size(u_out,3)) _ASSERT(size(v_in,3) == size(v_out,3)) diff --git a/MAPL_Base/MAPL_LatLonGridFactory.F90 b/MAPL_Base/MAPL_LatLonGridFactory.F90 index a4c65000220c..29df1034442c 100644 --- a/MAPL_Base/MAPL_LatLonGridFactory.F90 +++ b/MAPL_Base/MAPL_LatLonGridFactory.F90 @@ -96,6 +96,9 @@ module MAPL_LatLonGridFactoryMod procedure :: append_variable_metadata procedure :: check_decomposition procedure :: generate_newnxy + procedure :: generate_file_bounds + procedure :: generate_file_reference2D + procedure :: generate_file_reference3D end type LatLonGridFactory character(len=*), parameter :: MOD_NAME = 'MAPL_LatLonGridFactory::' @@ -138,6 +141,8 @@ function Latlongridfactory_basic(grid_name, & integer :: status character(*), parameter :: IAM = __FILE__ + _UNUSED_DUMMY(unusable) + factory%is_regular = .false. factory%grid_name = grid_name @@ -333,6 +338,8 @@ function get_longitudes(this, unusable, rc) result(longitudes) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(unusable) + longitudes = this%lon_centers _RETURN(_SUCCESS) end function get_longitudes @@ -346,6 +353,8 @@ function get_latitudes(this, unusable, rc) result(latitudes) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(unusable) + latitudes = this%lat_centers _RETURN(_SUCCESS) end function get_latitudes @@ -454,6 +463,8 @@ function get_lon_corners(this, unusable, rc) result(lon_corners) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(unusable) + lon_corners = this%lon_corners _RETURN(_SUCCESS) @@ -468,6 +479,8 @@ function get_lat_corners(this, unusable, rc) result(lat_corners) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(unusable) + lat_corners = this%lat_corners _RETURN(_SUCCESS) @@ -1376,6 +1389,8 @@ function check_decomposition(this,unusable,rc) result(can_decomp) integer, optional, intent(out) :: rc logical :: can_decomp integer :: n + _UNUSED_DUMMY(unusable) + can_decomp = .true. if (this%im_world==1 .and. this%jm_world==1) then _RETURN(_SUCCESS) @@ -1394,6 +1409,8 @@ subroutine generate_newnxy(this,unusable,rc) integer, optional, intent(out) :: rc integer :: n + _UNUSED_DUMMY(unusable) + n = this%im_world/this%nx if (n < 2) then this%nx = generate_new_decomp(this%im_world,this%nx) @@ -1660,6 +1677,7 @@ function get_grid_vars(this) result(vars) class (LatLonGridFactory), intent(inout) :: this character(len=:), allocatable :: vars + _UNUSED_DUMMY(this) vars = 'lon,lat' @@ -1668,6 +1686,52 @@ end function get_grid_vars subroutine append_variable_metadata(this,var) class (LatLonGridFactory), intent(inout) :: this type(Variable), intent(inout) :: var + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(var) end subroutine append_variable_metadata + subroutine generate_file_bounds(this,grid,local_start,global_start,global_count,rc) + use MAPL_BaseMod + class(LatLonGridFactory), intent(inout) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, allocatable, intent(inout) :: local_start(:) + integer, allocatable, intent(inout) :: global_start(:) + integer, allocatable, intent(inout) :: global_count(:) + integer, optional, intent(out) :: rc + + integer :: status + integer :: global_dim(3), i1,j1,in,jn + character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' + _UNUSED_DUMMY(this) + + call MAPL_GridGet(grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_GridGetInterior(grid,i1,in,j1,jn) + allocate(local_start,source=[i1,j1]) + allocate(global_start,source=[1,1]) + allocate(global_count,source=[global_dim(1),global_dim(2)]) + + _RETURN(_SUCCESS) + + end subroutine generate_file_bounds + + function generate_file_reference2D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(LatLonGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference2D + + function generate_file_reference3D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(LatLonGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference3D + + end module MAPL_LatLonGridFactoryMod diff --git a/MAPL_Base/MAPL_LatLonToLatLonRegridder.F90 b/MAPL_Base/MAPL_LatLonToLatLonRegridder.F90 index 5ba245610d41..39e93ef5c680 100644 --- a/MAPL_Base/MAPL_LatLonToLatLonRegridder.F90 +++ b/MAPL_Base/MAPL_LatLonToLatLonRegridder.F90 @@ -284,6 +284,9 @@ subroutine apply_weights_real32(this, q_in, q_out, rc) real :: q, w, f real(kind=REAL32) :: undef + + _UNUSED_DUMMY(rc) + undef = -HUGE(1.) do j = 1, this%num_points_out(2) @@ -344,6 +347,9 @@ subroutine apply_weights_real64(this, q_in, q_out, rc) real :: q, w, f real(kind=REAL64) :: undef + + _UNUSED_DUMMY(rc) + undef = -HUGE(1.d0) do j = 1, this%num_points_out(2) @@ -479,14 +485,13 @@ subroutine initialize_subclass(this, unusable, rc) type (RegridderSpec) :: spec logical :: cyclic_dim,hasPoles,stagger - integer :: dim,nsize,nin,j + integer :: dim,nsize,nin type(Weights), pointer :: WeightList(:) => null() real(kind=REAL64), allocatable :: xg_in(:),xg_out(:) real(kind=REAL32), allocatable :: xf_in(:),xf_out(:) - real(kind=REAL64) :: xMaxIn,xMaxOut,xMinIn,xMinOut,rngIn,rngOut,dx_in,dx_out + real(kind=REAL64) :: xMaxIn,xMaxOut,xMinIn,xMinOut,rngIn,rngOut type(dimensionSpec) :: dimspec character(len=ESMF_MAXSTR) :: grid_type - character(len=1024) :: error_msg _UNUSED_DUMMY(unusable) diff --git a/MAPL_Base/MAPL_LocStreamMod.F90 b/MAPL_Base/MAPL_LocStreamMod.F90 index ccdf24c9db9e..b20320075f45 100644 --- a/MAPL_Base/MAPL_LocStreamMod.F90 +++ b/MAPL_Base/MAPL_LocStreamMod.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" @@ -156,7 +155,7 @@ logical function MAPL_LocStreamIsAssociated(LocStream, RC) type(MAPL_LocStream), intent(IN ) :: LocStream integer, optional, intent( OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamIsAssocited' + MAPL_LocStreamIsAssociated = associated(LocStream%Ptr) @@ -169,7 +168,7 @@ logical function MAPL_LocStreamXformIsAssociated(Xform, RC) type(MAPL_LocStreamXform), intent(IN ) :: Xform integer, optional, intent( OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamXformIsAssocited' + MAPL_LocStreamXformIsAssociated = associated(Xform%Ptr) @@ -204,7 +203,7 @@ subroutine MAPL_LocStreamGet(LocStream, NT_LOCAL, TILETYPE, TILEKIND, & ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamGet' + #ifdef __GFORTRAN__ integer :: i integer, pointer :: tmp_iptr(:) => null() @@ -362,7 +361,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamCreateFromFile' + integer :: STATUS integer :: UNIT @@ -1106,7 +1105,7 @@ subroutine GetBilinearCoeffs(X0,Y0,DX,DY,X,Y,II,JJ,D,RC) real, intent( OUT) :: D(-1:,-1:) integer, optional, intent( OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm='GetBilinearCoeffs' + integer :: STATUS real :: DX0, DY0 real :: X00, Y00 @@ -1155,7 +1154,7 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) real, intent( OUT) :: D(-1:,-1:) integer, optional, intent( OUT) :: RC - character(len= ESMF_MAXSTR) :: IAm='GetBilinearCoeffs' + integer :: STATUS real, dimension(3) :: pp, p0, dp, dpx, dpy @@ -1337,7 +1336,7 @@ subroutine MAPL_LocStreamCreateFromStream(LocStreamOut, LocStreamIn, NAME, MASK, ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamCreateFromStream' + integer :: STATUS integer :: N, I, K, NT @@ -1474,7 +1473,7 @@ subroutine MAPL_LocStreamAttachGrid(LocStream, GRID, ISMINE, RC) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamAttachGrid' + integer :: STATUS type(MAPL_LocStreamType), pointer :: STREAM @@ -1558,7 +1557,7 @@ subroutine MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamCreateTileGrid' + integer :: STATUS @@ -1648,7 +1647,7 @@ subroutine MAPL_LocStreamAdjustNsubtiles(LocStream, NSUBTILES, RC) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamAdjustNsubtiles' + integer :: STATUS type(MAPL_LocStreamType), pointer :: STREAM @@ -1695,7 +1694,7 @@ subroutine MAPL_LocStreamTransformField (LocStream, OUTPUT, INPUT, MASK, & ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransform' + integer :: STATUS integer :: N, NT @@ -1779,7 +1778,7 @@ subroutine MAPL_LocStreamFracArea (LocStream, TYPE, AREA, RC ) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamFracArea' + integer :: II, JJ, N @@ -1829,7 +1828,7 @@ subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, T ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransformT2G' + integer :: STATUS real, allocatable :: FF(:,:) integer :: II, JJ, N, I1, IN, J1, JN @@ -1970,7 +1969,7 @@ subroutine MAPL_LocStreamTransformG2T ( LocStream, OUTPUT, INPUT, & ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransformG2T' + integer :: STATUS integer :: N, I1, IN, J1, JN, I, J, IM, JM @@ -2129,7 +2128,7 @@ subroutine MAPL_LocStreamTileWeight ( LocStream, OUTPUT, INPUT, RC ) integer :: N - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTileWeight' + ! Fill output subject to mask @@ -2162,7 +2161,7 @@ subroutine MAPL_LocStreamTransformT2T ( OUTPUT, XFORM, INPUT, RC ) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransformT2T' + integer :: STATUS integer :: N, offset @@ -2314,7 +2313,7 @@ subroutine MAPL_LocStreamTransformT2TR4R8 ( OUTPUT, XFORM, INPUT, RC ) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransformT2TR4R8' + integer :: STATUS #ifdef OLD_RUN @@ -2381,7 +2380,7 @@ subroutine MAPL_LocStreamTransformT2TR8R4 ( OUTPUT, XFORM, INPUT, RC ) ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamTransformT2TR8R4' + integer :: STATUS #ifdef OLD_RUN @@ -2442,7 +2441,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M ! Local variables - character(len=ESMF_MAXSTR) :: IAm='MAPL_LocStreamCreateXform' + integer :: STATUS integer :: N, M, MM @@ -2763,7 +2762,7 @@ integer function GRIDINDEX(STREAM,GRID,RC) type(ESMF_Grid), intent(IN ) :: Grid integer, optional, intent(OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm='GridIndex' + integer :: STATUS integer :: N @@ -2797,7 +2796,7 @@ subroutine MAPL_GridCoordAdjust(GRID, LOCSTREAM, RC) ! local vars !------------ - character(len=ESMF_MAXSTR) :: IAm='MAPL_GridCoordAdjust' + integer :: STATUS integer :: NGRIDS diff --git a/MAPL_Base/MAPL_MemUtils.F90 b/MAPL_Base/MAPL_MemUtils.F90 index bb7726ef7e66..27292607f802 100755 --- a/MAPL_Base/MAPL_MemUtils.F90 +++ b/MAPL_Base/MAPL_MemUtils.F90 @@ -52,6 +52,7 @@ module MAPL_MemUtilsMod public MAPL_MemUtilsIsDisabled public MAPL_MemUtilsFree public MAPL_MemCommited + public MAPL_MemUsed #ifdef _CRAY public :: hplen @@ -449,6 +450,67 @@ end subroutine MAPL_MemUtilsWriteComm !####################################################################### + subroutine MAPL_MemUsed ( memtotal, used, percent_used, RC ) + + real, intent(out) :: memtotal, used, percent_used + integer, optional, intent(OUT ) :: RC + + ! This routine returns the memory usage on Linux systems. + ! It does this by querying a system file (file_name below). + + character(len=32) :: meminfo = '/proc/meminfo' + character(len=32) :: string + integer :: mem_unit + real :: multiplier, available + + character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_MemUtils:MAPL_MemUsed" + integer :: status + +#ifdef sysDarwin + memtotal = 0.0 + used = 0.0 + percent_used = 0.0 + RETURN_(ESMF_SUCCESS) +#else + available = -1 + memtotal = -1 +#endif + + + call get_unit(mem_unit) + open(UNIT=mem_unit,FILE=meminfo,FORM='formatted',IOSTAT=STATUS) + VERIFY_(STATUS) + do + read (mem_unit,'(a)', end=20) string + if ( index ( string, 'MemTotal:' ) == 1 ) then ! High Water Mark + read (string(10:LEN_trim(string)-2),*) memtotal + multiplier = 1.0 + if (trim(string(LEN_trim(string)-1:)) == "kB" ) & + multiplier = 1.0/1024. ! Convert from kB to MB + memtotal = memtotal * multiplier + endif + if ( index ( string, 'MemAvailable:' ) == 1 ) then ! Resident Memory + multiplier = 1.0 + read (string(14:LEN_trim(string)-2),*) available + if (trim(string(LEN_trim(string)-1:)) == "kB" ) & + multiplier = 1.0/1024. ! Convert from kB to MB + available = available * multiplier + endif + enddo +20 close(mem_unit) + + if (memtotal >= 0 .and. available >= 0) then + used = memtotal-available + percent_used = 100.0*(used/memtotal) + else + ! fail, but don't crash + used = -1 + percent_used = -1 + end if + + RETURN_(ESMF_SUCCESS) + end subroutine MAPL_MemUsed + subroutine MAPL_MemCommited ( memtotal, committed_as, percent_committed, RC ) real, intent(out) :: memtotal, committed_as, percent_committed diff --git a/MAPL_Base/MAPL_Mod.F90 b/MAPL_Base/MAPL_Mod.F90 index 47ddd4250e47..69ff52a003a3 100644 --- a/MAPL_Base/MAPL_Mod.F90 +++ b/MAPL_Base/MAPL_Mod.F90 @@ -1,4 +1,3 @@ -! $Id$ module MAPL_Mod @@ -48,7 +47,7 @@ module MAPL_Mod use MAPL_KeywordEnforcerMod use MAPL_SimpleCommSplitterMod use MAPL_SplitCommunicatorMod - + use MAPL_EtaHybridVerticalCoordinateMod logical, save, private :: mapl_is_initialized = .false. end module MAPL_Mod diff --git a/MAPL_Base/MAPL_NUOPCWrapperMod.F90 b/MAPL_Base/MAPL_NUOPCWrapperMod.F90 index 47edb6e5863a..d91e2cba0bec 100644 --- a/MAPL_Base/MAPL_NUOPCWrapperMod.F90 +++ b/MAPL_Base/MAPL_NUOPCWrapperMod.F90 @@ -327,6 +327,8 @@ subroutine CheckImport(model, rc) ! at the future stopTime, as it does its forward stepping from currentTime ! to stopTime. + _UNUSED_DUMMY(model) + rc = ESMF_SUCCESS end subroutine CheckImport @@ -338,10 +340,10 @@ subroutine initialize_data(model, rc) type(ESMF_State) :: import_state, export_state type(ESMF_Clock) :: clock - type(ESMF_Field) :: field + !type(ESMF_Field) :: field integer :: num_items - character(len=ESMF_MAXSTR), allocatable :: item_names(:) + !character(len=ESMF_MAXSTR), allocatable :: item_names(:) call ESMF_GridCompGet(model, clock = clock, importState = import_state, & exportState = export_state, rc = rc) diff --git a/MAPL_Base/MAPL_NewArthParser.F90 b/MAPL_Base/MAPL_NewArthParser.F90 index 3337f0a16544..c3b5070dbc70 100755 --- a/MAPL_Base/MAPL_NewArthParser.F90 +++ b/MAPL_Base/MAPL_NewArthParser.F90 @@ -759,7 +759,6 @@ SUBROUTINE CheckSyntax (FuncStr,Var,needed,ExtVar,rc) INTEGER :: ParCnt, & ! Parenthesis counter j,ib,in,lFunc LOGICAL :: isUndef - INTEGER :: status character(len=ESMF_MAXPATHLEN) :: func integer, allocatable :: ipos(:) character(len=ESMF_MAXSTR), parameter :: IAm="CheckSyntax" diff --git a/MAPL_Base/MAPL_NominalOrbitsMod.F90 b/MAPL_Base/MAPL_NominalOrbitsMod.F90 index 9d83f79c7c3b..ad1b020d335e 100644 --- a/MAPL_Base/MAPL_NominalOrbitsMod.F90 +++ b/MAPL_Base/MAPL_NominalOrbitsMod.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "unused_dummy.H" MODULE MAPL_NominalOrbitsMod IMPLICIT NONE diff --git a/MAPL_Base/MAPL_Profiler.F90 b/MAPL_Base/MAPL_Profiler.F90 index 40b122c6aa74..20c4e258ab82 100644 --- a/MAPL_Base/MAPL_Profiler.F90 +++ b/MAPL_Base/MAPL_Profiler.F90 @@ -1,5 +1,4 @@ -! $Id$ #include "MAPL_ErrLog.h" diff --git a/MAPL_Base/MAPL_RegridderManager.F90 b/MAPL_Base/MAPL_RegridderManager.F90 index 462a0304120c..7bf758c58a5d 100644 --- a/MAPL_Base/MAPL_RegridderManager.F90 +++ b/MAPL_Base/MAPL_RegridderManager.F90 @@ -233,8 +233,6 @@ function new_make_regridder_from_grids(this, grid_in, grid_out, regrid_method, u type (RegridderSpec) :: spec integer(ESMF_KIND_I8) :: id_in, id_out - type (EsmfRegridder), pointer :: esmf_regridder - _UNUSED_DUMMY(unusable) if (.not. this%initialized) then diff --git a/MAPL_Base/MAPL_RegridderSpec.F90 b/MAPL_Base/MAPL_RegridderSpec.F90 index 0ba1470a5fa1..6e48f4f99b92 100644 --- a/MAPL_Base/MAPL_RegridderSpec.F90 +++ b/MAPL_Base/MAPL_RegridderSpec.F90 @@ -98,7 +98,6 @@ end function new_RegridderTypeSpec logical function less_than(a, b) class (RegridderTypeSpec), intent(in) :: a type (RegridderTypeSpec), intent(in) :: b - logical :: greater_than ! Compare methods @@ -177,6 +176,8 @@ subroutine get_grid_type(this,unusable,InputGridType,OutputGridType,rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME//'get_grid_type' + _UNUSED_DUMMY(unusable) + if (present(InputGridType)) then call ESMF_AttributeGet(this%grid_in,'GridType',InputGridType,rc=status) _VERIFY(status) diff --git a/MAPL_Base/MAPL_SatVapor.F90 b/MAPL_Base/MAPL_SatVapor.F90 index 2bbedb5d14dc..30a83bd86bc4 100644 --- a/MAPL_Base/MAPL_SatVapor.F90 +++ b/MAPL_Base/MAPL_SatVapor.F90 @@ -1,5 +1,4 @@ -! $Id$ module MAPL_SatVaporMod diff --git a/MAPL_Base/MAPL_ShmemMod.F90 b/MAPL_Base/MAPL_ShmemMod.F90 index c9e04665e34e..1d692189fc93 100755 --- a/MAPL_Base/MAPL_ShmemMod.F90 +++ b/MAPL_Base/MAPL_ShmemMod.F90 @@ -8,6 +8,7 @@ module MAPL_ShmemMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64 use MAPL_ErrorHandlingMod + use pflogger, only: logging, Logger implicit none private @@ -1480,7 +1481,6 @@ function MAPL_GetNewRank(node,rc) result(rank) integer, optional, intent(out) :: rc integer :: rank - integer :: status rank = MAPL_NodeRankList(node)%RankLastUsed+1 if (rank > size(MAPL_NodeRankList(node)%rank)) then @@ -1511,6 +1511,7 @@ function getNodeComm(Comm, rc) result(NodeComm) integer :: i1, i2 integer, allocatable :: newNode(:) + class(Logger), pointer :: lgr NodeComm=MPI_COMM_NULL @@ -1612,18 +1613,17 @@ function getNodeComm(Comm, rc) result(NodeComm) 1, MPI_INTEGER, MPI_MAX, comm, status ) _VERIFY(STATUS) + lgr => logging%get_logger('MAPL.SHMEM') + if(rank==0) then - print * - print *, "In MAPL_Shmem:" if (MAPL_CoresPerNodeMin == MAPL_CoresPerNodeMax) then - print *, " NumCores per Node = ", NumCores + call lgr%info("NumCores per Node = %i0", NumCores) else - print *, " NumCores per Node varies from ", & - MAPL_CoresPerNodeMin, " to ", MAPL_CoresPerNodeMax + call lgr%info("NumCores per Node varies from %i0 to %i0", & + MAPL_CoresPerNodeMin, MAPL_CoresPerNodeMax) end if - print *, " NumNodes in use = ", NumColors - print *, " Total PEs = ", npes - print * + call lgr%info("NumNodes in use = %i0", NumColors) + call lgr%info("Total PEs = %i0", npes) end if deallocate(names,stat=STATUS) @@ -1656,6 +1656,7 @@ function getNodeRootsComm(Comm, rc) result(NodeRootsComm) integer :: NodeRootsComm integer :: STATUS, MyColor, NumNodes, npes, rank + class(Logger), pointer :: lgr NodeRootsComm=MPI_COMM_NULL @@ -1686,11 +1687,10 @@ function getNodeRootsComm(Comm, rc) result(NodeRootsComm) _ASSERT(MAPL_MyNodeNum == rank+1,'needs informative message') endif + lgr => logging%get_logger('MAPL.SHMEM') + if(rank==0) then - print * - print *, "In MAPL_InitializeShmem (NodeRootsComm):" - print *, " NumNodes in use = ", NumNodes - print * + call lgr%info("NumNodes in use = %i0", NumNodes) end if _RETURN(SHM_SUCCESS) diff --git a/MAPL_Base/MAPL_SimpleBundleMod.F90 b/MAPL_Base/MAPL_SimpleBundleMod.F90 index f31d4a20b564..62fd4d3bebca 100644 --- a/MAPL_Base/MAPL_SimpleBundleMod.F90 +++ b/MAPL_Base/MAPL_SimpleBundleMod.F90 @@ -188,7 +188,7 @@ Function MAPL_SimpleBundleCreateFromBundle ( Bundle, rc, & character(len=ESMF_MAXSTR) :: bundleName character(len=ESMF_MAXSTR) :: fieldName - __Iam__('MAPL_SimpleBundleCreate') + integer :: status self%Bundle => Bundle ! remember where it came from @@ -561,7 +561,7 @@ Function MAPL_SimpleBundleCreateFromState ( State, rc, & character(len=ESMF_MAXSTR) :: message type (ESMF_FieldBundle) :: Bundle - __Iam__('MAPL_SimpleBundleCreateFromState') + integer :: status call ESMF_StateGet(State, name=stateName, __RC__) @@ -608,7 +608,7 @@ subroutine MAPL_SimpleBundleDestroy (self, rc ) !EOP !----------------------------------------------------------------------------- - __Iam__('MAPL_SimpleBundleDestroy') + integer :: status deallocate(self%coords%Lons, self%coords%Lats, self%coords%Levs, __STAT__) deallocate(self%r1, self%r2, self%r3, __STAT__) @@ -655,7 +655,7 @@ Function MAPL_SimpleBundleRead (filename, bundle_name, grid, time, verbose, & !EOP !----------------------------------------------------------------------------- - __Iam__('MAPL_SimpleBundleRead') + integer :: status type(ESMF_FieldBundle), pointer :: Bundle allocate(Bundle, stat=STATUS) @@ -700,7 +700,7 @@ subroutine MAPL_SimpleBundleWrite1 ( self, filename, clock, verbose, rc ) ! --- type(MAPL_CFIO) :: cfio - __Iam__ ('MAPL_SimpleBundleWrite0') + integer :: status call MAPL_CFIOCreate ( cfio, filename, clock, self%Bundle, __RC__) call MAPL_CFIOWrite ( cfio, Clock, self%Bundle, verbose=verbose, __RC__) @@ -738,7 +738,7 @@ subroutine MAPL_SimpleBundleWrite2 ( self, filename, time, verbose, rc ) type(ESMF_TimeInterval) :: TimeStep type(ESMF_Clock) :: Clock type(MAPL_CFIO) :: cfio - __Iam__ ('MAPL_SimpleBundleWrite1') + integer :: status call ESMF_TimeIntervalSet( TimeStep, h=0, m=30, s=0, __RC__ ) CLOCK = ESMF_ClockCreate ( name="Clock", timeStep=TimeStep, startTime=Time, __RC__ ) @@ -864,8 +864,6 @@ function MAPL_SimpleBundleGetIndex ( self, name, rank, rc, quiet ) result(iq) logical :: quiet_ integer :: i - _Iam_("MAPL_SimpleBundleGetIndex") - if ( present(quiet) ) then quiet_ = quiet else diff --git a/MAPL_Base/MAPL_Sort.F90 b/MAPL_Base/MAPL_Sort.F90 index 8ebeeb0b1f5c..aef0d3a1c312 100644 --- a/MAPL_Base/MAPL_Sort.F90 +++ b/MAPL_Base/MAPL_Sort.F90 @@ -1,7 +1,6 @@ #include "MAPL_ErrLog.h" -! $Id$ !============================================================================= !BOP diff --git a/MAPL_Base/MAPL_TimeMethods.F90 b/MAPL_Base/MAPL_TimeMethods.F90 index 8fbff898095b..dddfcb2550da 100644 --- a/MAPL_Base/MAPL_TimeMethods.F90 +++ b/MAPL_Base/MAPL_TimeMethods.F90 @@ -40,14 +40,14 @@ function new_time_data(clock,ntime,frequency,offset,rc) result(tData) type(ESMF_TimeInterval) :: offset integer, optional, intent(Out) :: rc - integer :: status - tdata%clock=clock tdata%ntime=ntime tdata%frequency=frequency tdata%offset=offset tdata%funits="minutes" + _RETURN(ESMF_SUCCESS) + end function new_time_data function define_time_variable(this,rc) result(v) @@ -110,10 +110,11 @@ function compute_time_vector(this,metadata,rc) result(times) real, allocatable :: times(:) integer :: status - real :: scaleFactor + !real :: scaleFactor type(ESMF_Time) :: currTime,startTime type(ESMF_TimeInterval) :: tint - integer :: tindex,i + integer :: i + !integer :: tindex real(ESMF_KIND_R8) :: tint_s type(ESMFTimeVectorIterator) :: iter type(ESMF_Time), pointer :: tptr @@ -216,6 +217,9 @@ function get_start_time(this,metadata,rc) result(startTime) class(Variable), pointer :: v type(Attribute), pointer :: attr class(*), pointer :: units + + _UNUSED_DUMMY(this) + v => metadata%get_variable('time',rc=status) _VERIFY(status) attr => v%get_attribute('units') diff --git a/MAPL_Base/MAPL_TransposeRegridder.F90 b/MAPL_Base/MAPL_TransposeRegridder.F90 index 054a2f2cc3fd..389e01803a00 100644 --- a/MAPL_Base/MAPL_TransposeRegridder.F90 +++ b/MAPL_Base/MAPL_TransposeRegridder.F90 @@ -73,6 +73,9 @@ subroutine initialize_subclass(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(unusable) + ! This is a wrapper class and should not be directly ! initialized. _RETURN(_FAILURE) @@ -149,6 +152,9 @@ subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) character(len=*), parameter :: Iam = MOD_NAME//'regrid_vector_2d_real32' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%transpose_regrid(u_in, v_in, u_out, v_out, rc=status) _RETURN(status) @@ -167,6 +173,9 @@ subroutine regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rotate, rc) character(len=*), parameter :: Iam = MOD_NAME//'regrid_vector_2d_real64' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%transpose_regrid(u_in, v_in, u_out, v_out, rc=status) _RETURN(status) @@ -184,6 +193,9 @@ subroutine regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) character(len=*), parameter :: Iam = MOD_NAME//'regrid_vector_3d_real32' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%transpose_regrid(u_in, v_in, u_out, v_out, rotate=rotate, rc=status) _RETURN(status) @@ -321,6 +333,9 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_vector_2d_real32' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%regrid(u_in, v_in, u_out, v_out, rc=status) _RETURN(status) @@ -339,6 +354,9 @@ subroutine transpose_regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rot character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_vector_2d_real64' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%regrid(u_in, v_in, u_out, v_out, rc=status) _RETURN(status) @@ -358,6 +376,9 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_vector_3d_real32' integer :: status + + _UNUSED_DUMMY(rotate) + call this%reference%regrid(u_in, v_in, u_out, v_out, rotate=rotate, rc=status) _RETURN(status) @@ -429,6 +450,7 @@ end function get_spec function isTranspose(this) result(amTranspose) logical :: amTranspose class (TransposeRegridder), intent(in) :: this + _UNUSED_DUMMY(this) amTranspose = .true. end function isTranspose diff --git a/MAPL_Base/MAPL_TripolarGridFactory.F90 b/MAPL_Base/MAPL_TripolarGridFactory.F90 index a7c05ab8adff..2aeb2762fc46 100644 --- a/MAPL_Base/MAPL_TripolarGridFactory.F90 +++ b/MAPL_Base/MAPL_TripolarGridFactory.F90 @@ -74,6 +74,9 @@ module MAPL_TripolarGridFactoryMod procedure :: append_metadata procedure :: get_grid_vars procedure :: append_variable_metadata + procedure :: generate_file_bounds + procedure :: generate_file_reference2D + procedure :: generate_file_reference3D end type TripolarGridFactory character(len=*), parameter :: MOD_NAME = 'MAPL_TripolarGridFactory::' @@ -286,9 +289,10 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, rc) integer, optional, intent(out) :: rc character(len=*), parameter :: Iam= MOD_NAME // 'initialize_from_file_metadata()' - integer :: status + _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(rc) end subroutine initialize_from_file_metadata @@ -545,8 +549,8 @@ function generate_grid_name(this) result(name) class (TripolarGridFactory), intent(in) :: this _UNUSED_DUMMY(this) - _UNUSED_DUMMY(name) + name = '' ! needs to be implemented error stop -1 @@ -907,6 +911,7 @@ function get_grid_vars(this) result(vars) class (TripolarGridFactory), intent(inout) :: this character(len=:), allocatable :: vars + _UNUSED_DUMMY(this) vars = 'lon,lat' @@ -915,7 +920,44 @@ end function get_grid_vars subroutine append_variable_metadata(this,var) class (TripolarGridFactory), intent(inout) :: this type(Variable), intent(inout) :: var + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(var) end subroutine append_variable_metadata + subroutine generate_file_bounds(this,grid,local_start,global_start,global_count,rc) + use MAPL_BaseMod + class(TripolarGridFactory), intent(inout) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, allocatable, intent(inout) :: local_start(:) + integer, allocatable, intent(inout) :: global_start(:) + integer, allocatable, intent(inout) :: global_count(:) + integer, optional, intent(out) :: rc + + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(grid) + _UNUSED_DUMMY(local_start) + _UNUSED_DUMMY(global_start) + _UNUSED_DUMMY(global_count) + _UNUSED_DUMMY(rc) + + end subroutine generate_file_bounds + + function generate_file_reference2D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(TripolarGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference2D + + function generate_file_reference3D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(TripolarGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference3D end module MAPL_TripolarGridFactoryMod diff --git a/MAPL_Base/MAPL_VarSpecMod.F90 b/MAPL_Base/MAPL_VarSpecMod.F90 index c1c14c9d57a8..3c5a89cee2fa 100644 --- a/MAPL_Base/MAPL_VarSpecMod.F90 +++ b/MAPL_Base/MAPL_VarSpecMod.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" @@ -220,7 +219,7 @@ subroutine MAPL_VarSpecCreateInList(SPEC, SHORT_NAME, LONG_NAME, & integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecCreateInList" + integer :: STATUS type (MAPL_VarSpec ), pointer :: TMP(:) => null() @@ -582,7 +581,7 @@ subroutine MAPL_VarSpecAddRefFromItem(SPEC, ITEM, ALLOW_DUPLICATES, RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecAddRefFromItem" + integer :: STATUS type (MAPL_VarSpec ), pointer :: TMP(:) => null() @@ -649,7 +648,7 @@ subroutine MAPL_VarSpecAddRefFromList(SPEC,ITEM,RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecAddRefFromList" + integer :: STATUS integer I @@ -672,7 +671,7 @@ function MAPL_VarSpecGetIndexByName(SPEC, NAME, RC) result (INDEX) integer, optional , intent(OUT) :: RC integer :: INDEX - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetIndexByName" + integer :: I @@ -701,7 +700,7 @@ subroutine MAPL_VarSpecGetDataByName(SPEC, NAME, PTR1, PTR2, PTR3, RC) real, optional, pointer :: PTR3(:,:,:) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetDataByName" + integer :: STATUS integer :: I @@ -730,7 +729,7 @@ subroutine MAPL_VarSpecGetData(SPEC, PTR1, PTR2, PTR3, RC) real, optional, pointer :: PTR3(:,:,:) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetData" + integer :: STATUS type(ESMF_Array) :: ARRAY @@ -773,7 +772,7 @@ function MAPL_VarSpecGetIndexOfItem(SPEC, ITEM, RC) result (INDEX) integer, optional , intent(OUT) :: RC integer :: INDEX - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetIndexOfItem" + integer :: I @@ -803,7 +802,7 @@ subroutine MAPL_VarSpecAddFromItem(SPEC,ITEM,RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecAddFromItem" + integer :: STATUS @@ -851,7 +850,7 @@ subroutine MAPL_VarSpecAddFromList(SPEC,ITEM,RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecAddFromList" + integer :: STATUS integer I @@ -872,7 +871,7 @@ subroutine MAPL_VarSpecDestroy0(SPEC, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecDestroy" + if(associated(SPEC%SPECPtr)) then deallocate(SPEC%SPECPtr) @@ -888,7 +887,7 @@ subroutine MAPL_VarSpecDestroy1(SPEC, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecDestroy" + integer :: i if (associated(SPEC)) then @@ -940,7 +939,7 @@ subroutine MAPL_VarSpecSetRegular(SPEC, SHORT_NAME, LONG_NAME, UNITS, & integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecSet" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1038,7 +1037,7 @@ subroutine MAPL_VarSpecSetFieldPtr(SPEC, FIELDPTR, RC ) integer , optional , intent( OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecSetFieldPtr" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1057,7 +1056,7 @@ subroutine MAPL_VarSpecSetBundlePtr(SPEC, BUNDLEPTR, RC ) integer , optional , intent( OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecSetBundlePtr" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1076,7 +1075,7 @@ subroutine MAPL_VarSpecSetStatePtr(SPEC, STATEPTR, RC ) integer , optional , intent( OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecSetStatePtr" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1151,7 +1150,7 @@ subroutine MAPL_VarSpecGetRegular(SPEC, SHORT_NAME, LONG_NAME, UNITS, & integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGet" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1304,7 +1303,7 @@ subroutine MAPL_VarSpecGetFieldPtr(SPEC, FIELDPTR, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetFieldPtr" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1323,7 +1322,7 @@ subroutine MAPL_VarSpecGetBundlePtr(SPEC, BundlePTR, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetBundlePtr" + if(.not.associated(SPEC%SPECPtr)) then _RETURN(ESMF_FAILURE) @@ -1342,7 +1341,7 @@ subroutine MAPL_VarSpecGetStatePtr(SPEC, StatePTR, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecGetStatePtr" + if(.not.associated(SPEC%SPECPtr)) then @@ -1363,7 +1362,7 @@ subroutine MAPL_VarSpecAddChildName(SPEC,CN,RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecAddChildName" + integer K @@ -1383,7 +1382,7 @@ subroutine MAPL_VarSpecReconnect(SPEC,ITEM,RC) integer, optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecReconnect" + integer :: STATUS type(ESMF_Field), pointer :: FIELD @@ -1502,7 +1501,7 @@ subroutine MAPL_VarConnCreate(CONN, SHORT_NAME, TO_NAME, & - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarConnCreate" + integer :: STATUS type (MAPL_VarConn ), pointer :: TMP(:) => null() @@ -1581,7 +1580,7 @@ subroutine MAPL_VarConnGet(CONN, SHORT_NAME, & - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarConnGet" + if(.not.associated(CONN%CONNPtr)) then @@ -1621,7 +1620,7 @@ logical function MAPL_VarIsConnectedEE(CONN, SHORT_NAME, & integer, intent( OUT) :: RC ! Error code: - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarIsConnectedEE" + integer :: I integer :: FI, TI, FE, TE @@ -1677,7 +1676,7 @@ logical function MAPL_VarIsConnectedIE(CONN, IMPORT_NAME, EXPORT_NAME, & integer, optional, intent( OUT) :: RC ! Error code: - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarIsConnectedIE" + integer :: I integer :: FI, TI, FE, TE @@ -1748,7 +1747,7 @@ logical function MAPL_VarIsListed(CONN, SHORT_NAME, IMPORT, RC) integer, optional, intent(OUT) :: RC ! Error code: - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarIsListed" + integer :: I integer :: FI, TI, FE, TE @@ -1793,7 +1792,7 @@ subroutine MAPL_VarSpecPrintOne(SPEC, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecPrint" + character(len=3) :: tmp character(len=ESMF_MAXSTR) :: string @@ -1824,7 +1823,7 @@ subroutine MAPL_VarSpecPrintMany(SPEC, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecPrintMany" + integer :: STATUS integer :: I @@ -1848,7 +1847,7 @@ subroutine MAPL_VarSpecPrint1CSV(SPEC, compName, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecPrint1CSV" + character(len=3) :: dimensions character(len=ESMF_MAXSTR) :: specInfo @@ -1872,7 +1871,7 @@ subroutine MAPL_VarSpecPrintCSV(SPEC, compName, RC ) integer , optional , intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_VarSpecPrintCSV" + integer :: STATUS integer :: I @@ -1915,7 +1914,7 @@ subroutine MAPL_ConnCheckReq(CONN, ImSpecPtr, ExSpecPtr, RC) type (MAPL_VarSpecPtr), pointer :: ExSpecPtr(:) integer, optional, intent(OUT) :: RC - character(len=ESMF_MAXSTR), parameter :: IAm="MAPL_ConnCheckReq" + integer :: I, J integer :: IMP integer :: FI diff --git a/MAPL_Base/MAPL_VerticalInterpMod.F90 b/MAPL_Base/MAPL_VerticalInterpMod.F90 index db21d4bc4bb2..c5695275b236 100644 --- a/MAPL_Base/MAPL_VerticalInterpMod.F90 +++ b/MAPL_Base/MAPL_VerticalInterpMod.F90 @@ -63,7 +63,6 @@ subroutine vertInterpolation_pressKappa (fModel, fPres, ps, plevs, & character(len=1) :: vartype real(REAL64), allocatable :: ak(:),bk(:) integer :: status - character(len=ESMF_MAXSTR) :: Iam = "MAPL_VerticalInterp" real :: gfactor type(ESMF_Grid) :: grid real, pointer :: vMod(:,:,:), vPres(:,:,:), vPS(:,:), vPHIS(:,:) diff --git a/MAPL_Base/MAPL_VerticalMethods.F90 b/MAPL_Base/MAPL_VerticalMethods.F90 index 24fdc9ec5d02..109666350475 100644 --- a/MAPL_Base/MAPL_VerticalMethods.F90 +++ b/MAPL_Base/MAPL_VerticalMethods.F90 @@ -62,8 +62,6 @@ function newVerticalData(levels,vcoord,vscale,vunit,rc) result(vdata) character(len=*), optional, intent(in) :: vunit integer, optional, intent(Out) :: rc - integer :: status - if (.not.present(levels)) then vdata%regrid_type = VERTICAL_METHOD_NONE _RETURN(ESMF_SUCCESS) diff --git a/MAPL_Base/MAPL_ioClients.F90 b/MAPL_Base/MAPL_ioClients.F90 index 70d7098732c4..e2f366c78398 100644 --- a/MAPL_Base/MAPL_ioClients.F90 +++ b/MAPL_Base/MAPL_ioClients.F90 @@ -51,6 +51,7 @@ subroutine init_io_clients(this, unusable, ni, no, rc) i_Clients = ClientManager(n_client=n_i) o_Clients = ClientManager(n_client=n_o) _RETURN(_SUCCESS) + _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) end subroutine diff --git a/MAPL_Base/MAPL_newCFIO.F90 b/MAPL_Base/MAPL_newCFIO.F90 index a28126560527..b32e159cc674 100644 --- a/MAPL_Base/MAPL_newCFIO.F90 +++ b/MAPL_Base/MAPL_newCFIO.F90 @@ -86,8 +86,6 @@ function new_MAPL_newCFIO(metadata,input_bundle,output_bundle,write_collection_i type(newCFIOitemVector), intent(in), optional :: items integer, intent(out), optional :: rc - integer :: status - if (present(metadata)) newCFIO%metadata=metadata if (present(input_bundle)) newCFIO%input_bundle=input_bundle if (present(output_bundle)) newCFIO%output_bundle=output_bundle @@ -336,7 +334,7 @@ subroutine bundlepost(this,filename,oClients,rc) integer :: status type(ESMF_Field) :: outField - integer :: tindex,request_id + integer :: tindex type(ArrayReference) :: ref type(newCFIOitemVectorIterator) :: iter @@ -601,23 +599,24 @@ subroutine stage2DLatLon(this, fileName, oClients, rc) type (ClientManager), optional, intent(inout) :: oClients integer, optional, intent(out) :: rc - integer :: request_id integer :: status - logical :: isCubed real(REAL64), pointer :: ptr2d(:,:) type(ArrayReference) :: ref - integer :: i1,in,j1,jn,tile - integer :: global_dim(3) - - call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - isCubed=.false. - if (global_dim(1)*6 == global_dim(2)) isCubed=.true. - - if (isCubed) then + class (AbstractGridFactory), pointer :: factory + integer, allocatable :: localStart(:),globalStart(:),globalCount(:) + logical :: hasll + class(Variable), pointer :: var_lat,var_lon + + var_lon => this%metadata%get_variable('lons') + var_lat => this%metadata%get_variable('lats') + + hasll = associated(var_lon) .and. associated(var_lat) + if (hasll) then + factory => get_factory(this%output_grid,rc=status) + _VERIFY(status) - call MAPL_Grid_interior(this%output_grid,i1,in,j1,jn) - tile = j1/global_dim(1) + call factory%generate_file_bounds(this%output_grid,LocalStart,GlobalStart,GlobalCount,rc=status) + _VERIFY(status) call ESMF_GridGetCoord(this%output_grid, localDE=0, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=ptr2d, rc=status) @@ -625,22 +624,20 @@ subroutine stage2DLatLon(this, fileName, oClients, rc) if (.not.allocated(this%lons)) allocate(this%lons(size(ptr2d,1),size(ptr2d,2))) this%lons=ptr2d*MAPL_RADIANS_TO_DEGREES ref = ArrayReference(this%lons) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),'lons', & - ref,start=[i1,j1-tile*global_dim(1),tile+1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(1),6]) + call oClients%collective_stage_data(this%write_collection_id,trim(filename),'lons', & + ref,start=localStart, global_start=GlobalStart, global_count=GlobalCount) call ESMF_GridGetCoord(this%output_grid, localDE=0, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=ptr2d, rc=status) _VERIFY(STATUS) if (.not.allocated(this%lats)) allocate(this%lats(size(ptr2d,1),size(ptr2d,2))) - !ref = ArrayReference(ptr2d) this%lats=ptr2d*MAPL_RADIANS_TO_DEGREES ref = ArrayReference(this%lats) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),'lats', & - ref,start=[i1,j1-tile*global_dim(1),tile+1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(1),6]) + call oClients%collective_stage_data(this%write_collection_id,trim(filename),'lats', & + ref,start=localStart, global_start=GlobalStart, global_count=GlobalCount) end if + end subroutine stage2DLatLon subroutine stageData(this, field, fileName, tIndex, oClients, rc) @@ -651,91 +648,57 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) type (ClientManager), optional, intent(inout) :: oClients integer, optional, intent(out) :: rc - integer :: request_id integer :: status integer :: fieldRank character(len=ESMF_MAXSTR) :: fieldName - logical :: isCubed real, pointer :: ptr3d(:,:,:) => null() real, pointer :: ptr2d(:,:) => null() type(ArrayReference) :: ref - integer :: i1,in,j1,jn,tile,lm - integer :: global_dim(3) - type(c_ptr) :: cptr - real, pointer :: ptr_ref_3d(:,:,:,:,:) + integer :: lm logical :: hasDE + integer, allocatable :: localStart(:),globalStart(:),globalCount(:) + integer, allocatable :: gridLocalStart(:),gridGlobalStart(:),gridGlobalCount(:) + class (AbstractGridFactory), pointer :: factory - call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) + factory => get_factory(this%output_grid,rc=status) _VERIFY(status) hasDE = MAPL_GridHasDE(this%output_grid,rc=status) _VERIFY(status) - isCubed=.false. - if (global_dim(1)*6 == global_dim(2)) isCubed=.true. lm = this%vdata%lm - call MAPL_Grid_interior(this%output_grid,i1,in,j1,jn) call ESMF_FieldGet(field,rank=fieldRank,name=fieldName,rc=status) _VERIFY(status) - if (isCubed) then - tile = j1/global_dim(1) - if (fieldRank==2) then - if (hasDE) then - call ESMF_FieldGet(field,farrayPtr=ptr2d,rc=status) - _VERIFY(status) - if (this%nbits < 24) then - call pFIO_DownBit(ptr2d,ptr2d,this%nbits,undef=MAPL_undef,rc=status) - _VERIFY(status) - end if - end if - ref = ArrayReference(ptr2d) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),trim(fieldName), & - ref,start=[i1,j1-tile*global_dim(1),tile+1,1], & - global_start=[1,1,1,tindex], global_count=[global_dim(1),global_dim(1),6,1]) - else if (fieldRank==3) then - if (hasDE) then - call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) + call factory%generate_file_bounds(this%output_grid,gridLocalStart,gridGlobalStart,gridGlobalCount,rc=status) + _VERIFY(status) + if (fieldRank==2) then + if (hasDE) then + call ESMF_FieldGet(Field,farrayPtr=ptr2d,rc=status) + _VERIFY(status) + if (this%nbits < 24) then + call pFIO_DownBit(ptr2d,ptr2d,this%nbits,undef=MAPL_undef,rc=status) _VERIFY(status) - if (this%nbits < 24) then - call pFIO_DownBit(ptr3d,ptr3d,this%nbits,undef=MAPL_undef,rc=status) - _VERIFY(status) - end if end if - cptr = c_loc(ptr3d) - call C_F_pointer(cptr,ptr_ref_3d,[size(ptr3d,1),size(ptr3d,2),1,size(ptr3d,3),1]) - ref = ArrayReference(ptr_ref_3d) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),trim(fieldName), & - ref,start=[i1,j1-tile*global_dim(1),tile+1,1,1], & - global_start=[1,1,1,1,tindex], global_count=[global_dim(1),global_dim(1),6,lm,1]) end if - else - if (fieldRank==2) then - if (hasDE) then - call ESMF_FieldGet(Field,farrayPtr=ptr2d,rc=status) - _VERIFY(status) - if (this%nbits < 24) then - call pFIO_DownBit(ptr2d,ptr2d,this%nbits,undef=MAPL_undef,rc=status) - _VERIFY(status) - end if - end if - ref = ArrayReference(Ptr2D) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),trim(fieldName), & - ref,start=[i1,j1,1], & - global_start=[1,1,tindex], global_count=[global_dim(1),global_dim(2),1]) - else if (fieldRank==3) then - if (HasDE) then - call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) + ref = factory%generate_file_reference2D(Ptr2D) + allocate(localStart,source=[gridLocalStart,1]) + allocate(globalStart,source=[gridGlobalStart,tindex]) + allocate(globalCount,source=[gridGlobalCount,1]) + else if (fieldRank==3) then + if (HasDE) then + call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) + _VERIFY(status) + if (this%nbits < 24) then + call pFIO_DownBit(ptr3d,ptr3d,this%nbits,undef=MAPL_undef,rc=status) _VERIFY(status) - if (this%nbits < 24) then - call pFIO_DownBit(ptr3d,ptr3d,this%nbits,undef=MAPL_undef,rc=status) - _VERIFY(status) - end if end if - ref = ArrayReference(Ptr3D) - call oClients%collective_stage_data(this%write_collection_id,trim(filename),trim(fieldName), & - ref,start=[i1,j1,1,1], & - global_start=[1,1,1,tindex], global_count=[global_dim(1),global_dim(2),lm,1]) end if - end if + ref = factory%generate_file_reference3D(Ptr3D) + allocate(localStart,source=[gridLocalStart,1,1]) + allocate(globalStart,source=[gridGlobalStart,1,tindex]) + allocate(globalCount,source=[gridGlobalCount,lm,1]) + end if + call oClients%collective_stage_data(this%write_collection_id,trim(filename),trim(fieldName), & + ref,start=localStart, global_start=GlobalStart, global_count=GlobalCount) end subroutine stageData @@ -804,18 +767,19 @@ subroutine request_data_from_file(this,filename,timeindex,rc) character(len=ESMF_MAXSTR), allocatable :: names(:) type(ESMF_Field) :: output_field type(ESMF_Field), allocatable :: input_fields(:) - integer :: ub(1),lb(1),i1,in,j1,jn,img,jmg,dims(3),lm,rank + integer :: ub(1),lb(1),dims(3),lm,rank type(ArrayReference) :: ref real, pointer :: ptr2d(:,:) => null() real, pointer :: ptr3d(:,:,:) => null() - integer, allocatable :: start(:) - integer, allocatable :: global_start(:) - integer, allocatable :: global_count(:) + integer, allocatable :: localStart(:), globalStart(:), globalCount(:) + integer, allocatable :: gridLocalStart(:), gridGlobalStart(:), gridGlobalCount(:) type(ESMF_Grid) :: output_grid logical :: hasDE + class(AbstractGridFactory), pointer :: factory collection => extdatacollections%at(this%metadata_collection_id) filegrid = collection%src_grid + factory => get_factory(filegrid) hasDE=MAPL_GridHasDE(filegrid,rc=status) _VERIFY(status) call ESMF_FieldBundleGet(this%output_bundle,grid=output_grid,rc=status) @@ -824,11 +788,10 @@ subroutine request_data_from_file(this,filename,timeindex,rc) this%regrid_handle => new_regridder_manager%make_regridder(filegrid,output_grid,this%regrid_method,rc=status) _VERIFY(status) end if - call MAPL_Grid_Interior(filegrid,i1,in,j1,jn) call MAPL_GridGet(filegrid,globalCellCountPerdim=dims,rc=status) _VERIFY(status) - img=dims(1) - jmg=dims(2) + call factory%generate_file_bounds(fileGrid,gridLocalStart,gridGlobalStart,gridGlobalCount,rc=status) + _VERIFY(status) ! create input bundle call ESMF_FieldBundleGet(this%output_bundle,fieldCount=numVars,rc=status) _VERIFY(status) @@ -853,10 +816,10 @@ subroutine request_data_from_file(this,filename,timeindex,rc) allocate(ptr2d(0,0),stat=status) _VERIFY(status) end if - ref=ArrayReference(ptr2d) - start = [i1, j1, timeIndex] ! (i,j,t) - global_start = [1, 1, timeIndex] ! (i,j,t) - global_count = [img, jmg, 1] + ref=factory%generate_file_reference2D(ptr2d) + allocate(localStart,source=[gridLocalStart,timeIndex]) + allocate(globalStart,source=[gridGlobalStart,timeIndex]) + allocate(globalCount,source=[gridGlobalCount,1]) else if (rank==3) then call ESMF_FieldGet(output_field,ungriddedLBound=lb,ungriddedUBound=ub,rc=status) _VERIFY(status) @@ -871,16 +834,17 @@ subroutine request_data_from_file(this,filename,timeindex,rc) allocate(ptr3d(0,0,0),stat=status) _VERIFY(status) end if - ref=ArrayReference(ptr3d) - start = [i1, j1, 1, timeIndex] ! (i,j,t) - global_start = [1, 1, 1, timeIndex] ! (i,j,t) - global_count = [img, jmg, lm, 1] + ref=factory%generate_file_reference3D(ptr3d) + allocate(localStart,source=[gridLocalStart,1,timeIndex]) + allocate(globalStart,source=[gridGlobalStart,1,timeIndex]) + allocate(globalCount,source=[gridGlobalCount,lm,1]) end if call i_Clients%collective_prefetch_data( & this%read_collection_id, fileName, trim(names(i)), & - & ref, start=start, global_start=global_start, global_count=global_count) - deallocate(start,global_start,global_count) + & ref, start=localStart, global_start=globalStart, global_count=globalCount) + deallocate(localStart,globalStart,globalCount) enddo + deallocate(gridLocalStart,gridGlobalStart,gridGlobalCount) this%input_bundle = ESMF_FieldBundleCreate(fieldList=input_fields,rc=status) _VERIFY(status) _RETURN(_SUCCESS) diff --git a/MAPL_Base/MAPL_sun_uc.F90 b/MAPL_Base/MAPL_sun_uc.F90 index 66966307412c..ab3e94b2d995 100644 --- a/MAPL_Base/MAPL_sun_uc.F90 +++ b/MAPL_Base/MAPL_sun_uc.F90 @@ -1,4 +1,3 @@ -! $Id$ #include "MAPL_ErrLog.h" @@ -38,6 +37,8 @@ module MAPL_SunMod public MAPL_SunOrbitQuery public MAPL_SunGetInsolation public MAPL_SunGetSolarConstant + public MAPL_SunGetDaylightDuration + public MAPL_SunGetDaylightDurationMax ! !PUBLIC TYPES: @@ -68,6 +69,7 @@ module MAPL_SunMod type MAPL_SunOrbit private + logical :: CREATED = .FALSE. type(ESMF_Clock) :: CLOCK real :: OB, ECC, PER, YEARLEN integer :: EQNX, YEARS_PER_CYCLE, DAYS_PER_CYCLE @@ -75,11 +77,101 @@ module MAPL_SunMod real, pointer, dimension(:) :: ZS => null() real, pointer, dimension(:) :: PP => null() real, pointer, dimension(:) :: TH => null() + real, pointer, dimension(:) :: ET => null() + logical :: EOT logical :: FIX_SUN + logical :: ANAL2B + real :: ORB2B_YEARLEN + type(ESMF_Time) :: ORB2B_TIME_REF + real :: ORB2B_ECC_REF + real :: ORB2B_ECC_RATE + real :: ORB2B_OBQ_REF + real :: ORB2B_OBQ_RATE + real :: ORB2B_LAMBDAP_REF + real :: ORB2B_LAMBDAP_RATE + type(ESMF_Time) :: ORB2B_TIME_EQUINOX + real :: ORB2B_OMG0 + type(ESMF_Time) :: ORB2B_TIME_PERI end type MAPL_SunOrbit contains +!========================================================================== + ! utlity functions + + ! rectify to [-pi,+pi) + function RECT_PMPI(X) + real :: X, RECT_PMPI + RECT_PMPI = MODULO( X + MAPL_PI, 2*MAPL_PI ) - MAPL_PI + end function + + ! true anomaly from eccentric anomaly + function calcTAfromEA(EA,EAFAC) result(TA) + real :: EA, EAFAC, TA + TA = 2. * atan( tan(EA / 2.) / EAFAC) + end function + + ! eccentric anomaly from true anomaly + function calcEAfromTA(TA,EAFAC) result(EA) + real :: TA, EAFAC, EA + EA = 2. * atan( EAFAC * tan(TA / 2.)) + end function + + ! mean anomaly from eccentric anomaly (Kepler's equation) + function calcMAfromEA(EA,ECC) result(MA) + real :: EA, ECC, MA + MA = EA - ECC * sin(EA) + end function + + ! eccentric anomaly from mean anomaly + ! (invert Kepler's equation by Newton-Raphson) + subroutine invert_Keplers_Newton( & + MA, ECC, & + EA, dE, nits, & + tol, max_its) + + real, intent(in ) :: MA + real, intent(in ) :: ECC + + real, intent(out) :: EA + real, intent(out) :: dE + integer, intent(out) :: nits + + real, optional, intent(in ) :: tol + integer, optional, intent(in ) :: max_its + + real :: f, df, tol_ + integer :: max_its_ + + if (present(tol)) then + tol_ = tol + else + tol_ = 1.e-10 + endif + + if (present(max_its)) then + max_its_ = max_its + else + max_its_ = 10 + endif + + EA = MA + do nits = 1, max_its_ + f = EA - ECC * sin(EA) - MA + df = 1. - ECC * cos(EA) + dE = -f / df + EA = EA + dE + if (abs(dE) < tol_) exit + enddo + + end subroutine + + ! Earth-Sun distance from true anomaly + function calcRadfromTA(TA,ECC,OMSQECC) result(Rad) + real :: TA, ECC, OMSQECC, Rad + Rad = OMSQECC / (1. + ECC * cos(TA)) + end function + !========================================================================== !BOPI @@ -96,6 +188,10 @@ module MAPL_SunMod ! ESMF clock passed as an argument. This becomes the orbit`s ! attached clock. Currently we assume a single intercalation. ! +! A good introduction to celestial mechanics for understanding +! this code can be found in Blanco & McCuskey, 1961: "Basic +! Physics of the Solar System", hereafter BM. +! !% \begin{itemize} !% \item[] !\makebox[2in][l]{\bf \em CLOCK} @@ -119,20 +215,92 @@ module MAPL_SunMod !% \item[] !\makebox[2in][l]{\bf \em EQUINOX} ! \parbox[t]{4in}{Day of year of vernal equinox. -! Equinox is assumed to occur at 0Z on this day -! on the first year of the cycle.} +! Equinox is assumed to occur at 0Z on this day on the +! first year of the cycle.} +!% \item[] +!\makebox[2in][l]{\bf \em EOT} +! \parbox[t]{4in}{Apply Equation of Time correction?} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORBIT\_ANAL2B} +! \parbox[t]{4in}{New orbital system (analytic two-body) allows some +! time-varying behavior, namely, linear time variation in LAMBDAP, +! ECC, and OBQ. If .TRUE., the following ORB2B parameters are used +! and only CLOCK and EOT above are used, i.e., the ECCENTRICITY, +! OBLIQUITY, PERIHELION and EQUINOX above are NOT used and are +! replaced by the relevant ORB2B parameters below.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_YEARLEN} +! \parbox[t]{4in}{Fixed anomalistic year length in mean solar days.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_REF\_YYYYMMDD} +! \parbox[t]{4in}{Reference date for orbital parameters.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_REF\_HHMMSS} +! \parbox[t]{4in}{Reference time for orbital parameters.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_ECC\_REF} +! \parbox[t]{4in}{Orbital eccentricity at reference date.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_ECC\_RATE} +! \parbox[t]{4in}{Rate of change of orbital eccentricity per Julian century.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_OBQ\_REF} +! \parbox[t]{4in}{Earth's obliquity (axial tilt) at reference date [degrees].} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_OBQ\_RATE} +! \parbox[t]{4in}{Rate of change of obliquity [degrees per Julian century].} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_LAMBDAP\_REF} +! \parbox[t]{4in}{Longitude of perihelion at reference date [degrees] +! (from March equinox to perihelion in direction of earth's motion).} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_LAMBDAP\_RATE} +! \parbox[t]{4in}{Rate of change of LAMBDAP [degrees per Julian century] +! (Combines both equatorial and ecliptic precession).} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_EQUINOX\_YYYYMMDD} +! \parbox[t]{4in}{March equinox date.} +! +!% \item[] +!\makebox[2in][l]{\bf \em ORB2B\_EQUINOX\_HHMMSS} +! \parbox[t]{4in}{March equinox time.} +! !% \end{itemize} ! ! !INTERFACE: -type(MAPL_SunOrbit) function MAPL_SunOrbitCreate(CLOCK, & - ECCENTRICITY,& - OBLIQUITY, & - PERIHELION, & - EQUINOX, & - FIX_SUN, & - RC ) +type(MAPL_SunOrbit) function MAPL_SunOrbitCreate(CLOCK, & + ECCENTRICITY, & + OBLIQUITY, & + PERIHELION, & + EQUINOX, & + 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, & + RC ) ! !ARGUMENTS: @@ -141,103 +309,435 @@ type(MAPL_SunOrbit) function MAPL_SunOrbitCreate(CLOCK, & real , intent(IN ) :: OBLIQUITY real , intent(IN ) :: PERIHELION integer , intent(IN ) :: EQUINOX + logical , intent(IN ) :: EOT + logical , intent(IN ) :: ORBIT_ANAL2B + real , intent(IN ) :: ORB2B_YEARLEN + integer , intent(IN ) :: ORB2B_REF_YYYYMMDD + integer , intent(IN ) :: ORB2B_REF_HHMMSS + real , intent(IN ) :: ORB2B_ECC_REF + real , intent(IN ) :: ORB2B_ECC_RATE + real , intent(IN ) :: ORB2B_OBQ_REF + real , intent(IN ) :: ORB2B_OBQ_RATE + real , intent(IN ) :: ORB2B_LAMBDAP_REF + real , intent(IN ) :: ORB2B_LAMBDAP_RATE + integer , intent(IN ) :: ORB2B_EQUINOX_YYYYMMDD + integer , intent(IN ) :: ORB2B_EQUINOX_HHMMSS logical, optional , intent(IN ) :: FIX_SUN integer, optional , intent(OUT) :: RC !EOPI +! ======================================= +! PMN Dec 2019: Notes on Equation of Time +! ======================================= +! (Part of a more complete analysis available in orbit.pdf) +! +! @ Introduction: +! +! The Earth rotates on its axis with a period T_S called the sidereal +! day (after the Latin for "star", since it is the rotation period of +! the Earth with respect to distant stars). T_S is slightly shorter +! than the so-called mean solar day, or clock day, of duration T_M = +! 86400 seconds. This is because the Earth is a prograde planet, i.e., +! it rotates about its axis in the same sense (counterclockwise look- +! ing down on the North Pole) as it orbits the sun. Specifically, say +! the sun crosses the meridian of some location at a particular time. +! And imagine there is a distant star directly behind the sun at that +! moment. After one sidereal day the location will rotate 360 degrees +! about the earth's axis and the distant star will again cross its +! merdian. But during that period the earth will have moved a small +! counterclockwise distance around its orbit and so it will take a +! small additional rotation of the earth for the sun to also cross +! the meridian and thereby complete a solar day. +! +! Put another way, a solar day is slightly longer than a sidereal day +! because the sun appears to move slowly eastward across the celestial +! sphere with respect to distant stars as the year passes. The path +! of this motion is called the ecliptic. And clearly what governs the +! length of a solar day is the apparent velocity of the sun along the +! ecliptic, or, more particularly, the equatorial component of that +! velocity. But both the magnitude and equatorial component of the solar +! ecliptic velocity change during the year, the former because the earth's +! orbit is elliptical, not circular, and the latter because the earth's +! axis of rotation is tilted with respect to the orbital (ecliptic) plane. +! Thus the length of a solar day changes during the year. While these +! factors cause only a small perturbation to the length of the solar +! day (less than 30 seconds), the perturbations accumulate so that at +! different times of the year apparent solar time ("sundial time") and +! mean solar time ("clock time") can differ by as much as ~15 minutes. +! This difference is called the Equation of Time. +! +! To be more rigorous, consider a fictitious "Mean Sun" that moves at +! constant eastward speed around the celestial equator, completing a +! full revolution in a year, namely in the period Y * T_M, where Y is +! the number of mean solar days in a year (e.g., 365.25). Thus, in one +! mean solar day, T_M, the mean sun has moved an angle 2*PI/Y eastward. +! Hence, beyond one full earth revolution, period T_S, an additional +! earth rotation of (T_M-T_S) * 2*PI/T_S = 2*PI/Y is required to "catch +! up with the moving sun", as described earlier. Hence T_M - T_S = T_S / Y +! and so +! +! T_M = T_S (Y+1)/Y, ..... (1) +! +! a constant (near unity) multiple of the fixed sidereal day. T_M is +! the length of the solar day for the "mean sun", or the "mean solar +! day". Because it is invariant during the year, it is convenient for +! timekeeping, and forms the basis for "mean solar time", which at +! Greenwich is essentially UTC. By *definition*, T_M = 24h = 86400s. +! That is, what we know as "hours", "minutes" and "seconds", are just +! convenient integer fractions of the mean solar day. In these units, +! the sidereal day T_S is approximately 23h 56m 4s. +! +! The solar zenith angle calculation (in MAPL_SunGetInsolation) needs +! the true local solar hour angle, h_T, which is the angle, measured +! westward along the equator, from the local meridian to the true sun. +! This is just the Greenwich solar hour angle, H_T, plus the longitude, +! so we will henceforth work exclusively with Greenwich hour angles. +! We should use the hour angle of the *true* sun, H_T, but a common +! approximation replaces this with the hour angle of the mean sun +! +! H_M = 2*PI*(u-0.5), ..... (2) +! +! where u is UTC time (in days) and the offset is needed because the mean +! solar hour angle is zero at "noon". If more accuracy is required, the +! hour angle of the true sun is typically obtained as a small correction +! to H_M called the Equation of time, EOT: +! +! H_T = H_M + EOT, where EOT = H_T - H_M. +! +! As discussed above, EOT corrects for two factors: +! (a) the variable speed of the earth in its elliptical orbit about +! the sun (e.g., moving fastest at perihelion), and +! (b) the tilt of the earth's axis of rotation wrt its orbital plane +! (the "obliquity"), which causes the equatorial projection of +! the sun's apparent ecliptic motion to vary with the season +! (e.g., being parallel to the equator at the solstices.) +! +! @ Derivation of Equation of Time: +! +! We can write +! +! H_T = H_1 - (H_1 - H_T) = H_1 - a_T, +! +! where H_1 is the Greenwich hour angle of the First Point of Aries (the +! location of the vernal equinox, denoted "1PoA"), and is also known as the +! Greenwich Sidereal hour angle, and where a_T is the right ascension of the +! true sun (since the right ascension of any object is just the difference +! between the hour angles of 1PoA and the object). Hence, +! +! EOT = H_1 - H_M - a_T. ..... (3) +! +! All three terms on the right of (3) are time variable: a_T changes slowly +! throughout the year, and is known from the earth-sun two-body elliptical +! orbit solution, while H_1 and H_M vary rapidly with earth's rotation. H_M +! has a period of one mean solar day, T_M, and H_1 has a period of one +! sidereal day, T_S. +! +! It may seem from from (2) that the mean sun and its hour angle are fully +! specified. That, in fact, is not yet the case: (2) is really just a def- +! inition of UTC, namely, that one UTC day is one mean solar day and that +! the time of culmination of the mean sun, what we call "noon", occurs at +! UTC 12h00m. What we are still at liberty to do is specify the phasing of +! the mean sun in its equatorial orbit, e.g., by specifying the time u_R +! at which the mean sun passes through 1PoA (both on the equator). At this +! time, H_1(u_R) = H_M(u_R), and so +! +! H_1(u) - H_M(u) = 2*PI*(u-u_R)*(Y+1)/Y - 2*PI*(u-u_R) +! = 2*PI * (u-u_R) / Y +! = MA(u) - MA(u_R), ... (4) +! +! where MA(u) = 2*PI * (u-u_P) / Y is the so-called "mean anomaly", known +! from the earth-sun two-body orbital solution, and u_P is the time of +! perihelion. Thus, to fully determine EOT, through (3) and (4), we need +! only to specify MA(u_R). +! +! To understand the mean anomaly MA, consider the standard two-body earth- +! sun problem in which the earth E moves in an elliptical orbit about the +! sun S at one focus, all in the ecliptic plane. The point on the ellipse +! closest to S is called the perihelion P. Obviously, the center of the +! ellipse O, the focus S and the perihelion P are co-linear, the so-called +! major axis of the ellipse. Additionally, let C be the circumscribing circle +! of the ellipse, with center O and passing through P (and the corresponding +! aphelion A). By Kepler's Second Law, the sun-earth vector sweeps out equal +! areas in equal times, so the fractional area of the elliptical sector PSE +! is a linear function of time, being zero at perihelion and one a year later. +! Specifically, this fractional area is none other than the scaled mean anomaly +! MA(u)/(2*PI) = (u - u_P) / Y. Clearly MA(u) can also be interpreted as an +! angle, the angle POQ of a point Q orbiting on the circumcircle C at constant +! speed in the same direction as the earth, also with a yearly period, and +! passing through P at the same time u_P as the earth. Thus the point Q can +! be conceptualized as a sort of "mean earth" orbiting a "second mean sun" +! (different from M above) at O. Note that while the angle MA(u) = angle POQ +! of this mean earth at time u is a linear function of time, the corresponding +! angle of the real earth, namely TA(u) = angle PSE, called the true anomaly, +! is a non-linear function of time, since the real earth has a variable speed +! in its elliptical orbit, e.g., moving faster at perihelion, so that its areal +! fraction is linear in time. The relationship between MA(u) and TA(u) is known +! from the orbital solution. Finally, the ecliptic longitude of the earth, +! lambda = angle 1SE is the angle at the sun, measured in the same direction +! as the earth's motion, from the First Point of Aries to the earth. Then +! +! TA(u) = angle PSE(u) = angle PS1 + angle 1SE(u) = lambda(u) - lambda_P, +! +! where lambda_P = lambda(u_P) = angle 1SP = -angle PS1 is known as the +! longitude of perihelion, and is currently about 283 deg, or equivalently +! -77 deg. +! +! With this background, we can understand the quantity MA(u_R) we are trying +! to specify. If we *choose* +! +! MA(u_R) = -lambda_P = angle PS1 ... (5) +! <==> angle POQ(u_R) = angle PS1, +! +! then at u_R, viewed from the mean earth Q, the second (ecliptic) mean sun +! O is in direction of 1PoA. And at that same time, by definition of u_R, +! the first (equatorial) mean sun M, as seen from the real earth E, is also +! in direction of 1PoA. +! +! I (PMN) have verified that the choice (5) for MA(u_R) leads to zero mean +! EOT to first order in the eccentricity, e. I cannot say, at this point, +! that it is generally true for any order in e. I add below a final explicit +! enforcement of zero mean EOT to the code. [I found that the order e^2 term +! for the mean EOT was NOT zero, and was larger than the mean EOT produced +! by this code (which is valid for all orders in e) before any explicity +! correction of the mean to zero. This suggests: (a) that I made a mistake +! in my calculations, or (b) that higer order e terms provide some cancel- +! ation.] +! +! Hence, finally, +! +! EOT(u) = MA(u) + PRHV - a_T(u) ... (6) +! +! where PRHV is the name for lamba_P in the code. +! =========================================================================== + ! Locals character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreate" - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: KM, K, KP - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT real*8 :: YEARLEN - integer :: STATUS + integer :: K, KP, YEARS_PER_CYCLE, DAYS_PER_CYCLE + real*8 :: TREL, T1, T2, T3, T4, dTRELdDAY + real*8 :: SOB, COB, OMG0, OMG, PRH, PRHV + real :: D2R, OMECC, OPECC, OMSQECC, EAFAC + real*8 :: X, TA, EA, MA, TRRA, MNRA + real :: meanEOT type(MAPL_SunOrbit) :: ORBIT + integer :: STATUS -! STATEMENT FUNCTION - - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - -!MJS: This needs to come from the calendar when the time manager works right. - - YEARLEN = 365.25 - -! Factors involving the orbital parameters -!------------------------------------------ - - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - -! Compute length of leap cycle -!------------------------------ + integer :: year, month, day, hour, minute, second + real(ESMF_KIND_R8) :: days + real :: ECC_EQNX, LAMBDAP_EQNX, EAFAC_EQNX + real :: TA_EQNX, EA_EQNX, MA_EQNX + type(ESMF_TimeInterval) :: DT + + ! STATEMENT FUNC: dTREL/dDAY(TREL), + ! where TREL is ecliptic longitude of true Sun + dTRELdDAY(TREL) = OMG*(1.0-ECCENTRICITY*cos(TREL-PRH))**2 + + ! useful constants + D2R = MAPL_PI / 180. + + ! record inputs needed by both orbit methods + ORBIT%CLOCK = CLOCK + ORBIT%EOT = EOT + ORBIT%ANAL2B = ORBIT_ANAL2B + + ! Analytic two-body orbit? + if (ORBIT_ANAL2B) then + + ! record inputs in ORBIT type + ORBIT%ORB2B_YEARLEN = ORB2B_YEARLEN + ORBIT%ORB2B_ECC_REF = ORB2B_ECC_REF + ORBIT%ORB2B_OBQ_REF = ORB2B_OBQ_REF * D2R ! radians + ORBIT%ORB2B_LAMBDAP_REF = ORB2B_LAMBDAP_REF * D2R ! radians + ORBIT%ORB2B_ECC_RATE = ORB2B_ECC_RATE / 36525. ! per day + ORBIT%ORB2B_OBQ_RATE = ORB2B_OBQ_RATE * D2R / 36525. ! radians per day + ORBIT%ORB2B_LAMBDAP_RATE = ORB2B_LAMBDAP_RATE * D2R / 36525. ! radians per day + ! record MAPL Time object for REFerence time + year = ORB2B_REF_YYYYMMDD / 10000 + month = mod(ORB2B_REF_YYYYMMDD, 10000) / 100 + day = mod(ORB2B_REF_YYYYMMDD, 100) + hour = ORB2B_REF_HHMMSS / 10000 + minute = mod(ORB2B_REF_HHMMSS, 10000) / 100 + second = mod(ORB2B_REF_HHMMSS, 100) + call ESMF_TimeSet(ORBIT%ORB2B_TIME_REF, & + yy=year, mm=month, dd=day, h=hour, m=minute, s=second, rc=STATUS) + _VERIFY(STATUS) + ! record MAPL Time object for EQUINOX + year = ORB2B_EQUINOX_YYYYMMDD / 10000 + month = mod(ORB2B_EQUINOX_YYYYMMDD, 10000) / 100 + day = mod(ORB2B_EQUINOX_YYYYMMDD, 100) + hour = ORB2B_EQUINOX_HHMMSS / 10000 + minute = mod(ORB2B_EQUINOX_HHMMSS, 10000) / 100 + second = mod(ORB2B_EQUINOX_HHMMSS, 100) + call ESMF_TimeSet(ORBIT%ORB2B_TIME_EQUINOX, & + yy=year, mm=month, dd=day, h=hour, m=minute, s=second, rc=STATUS) + _VERIFY(STATUS) + + ! time-invariant precalculations + ORBIT%ORB2B_OMG0 = 2. * MAPL_PI / ORB2B_YEARLEN + + ! at provided ORB2B_TIME_EQUINOX LAMBDA=0 by definition + call ESMF_TimeIntervalGet( & + ORBIT%ORB2B_TIME_EQUINOX - ORBIT%ORB2B_TIME_REF, & + d_r8=days, rc=STATUS) + _VERIFY(STATUS) + ECC_EQNX = ORBIT%ORB2B_ECC_REF + days * ORBIT%ORB2B_ECC_RATE + LAMBDAP_EQNX = ORBIT%ORB2B_LAMBDAP_REF + days * ORBIT%ORB2B_LAMBDAP_RATE + EAFAC_EQNX = sqrt((1.-ECC_EQNX)/(1.+ECC_EQNX)) + TA_EQNX = -LAMBDAP_EQNX ! since LAMBDA=0 + EA_EQNX = calcEAfromTA(TA_EQNX,EAFAC_EQNX) + MA_EQNX = calcMAfromEA(EA_EQNX,ECC_EQNX) + + ! Time of one perihelion (all subsequent ORB2B_YEARLEN apart) + call ESMF_TimeIntervalSet(DT, d_r8 = dble(MA_EQNX / ORBIT%ORB2B_OMG0)) + ORBIT%ORB2B_TIME_PERI = ORBIT%ORB2B_TIME_EQUINOX - DT - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - if(associated(ORBIT%TH)) deallocate(ORBIT%TH) - allocate(ORBIT%TH(DAYS_PER_CYCLE), stat=status) - _VERIFY(STATUS) + ! ================================== + ! Standard tabularized intercalation + ! ================================== + + ! MJS: This needs to come from the calendar when the time manager works right. + YEARLEN = 365.25 + + ! Factors involving the orbital parameters + !----------------------------------------- + OMECC = 1. - ECCENTRICITY + OPECC = 1. + ECCENTRICITY + OMSQECC = 1. - ECCENTRICITY**2 ! pmn: consider changing to line below when zero-diff not issue +! OMSQECC = OMECC * OPECC + EAFAC = sqrt(OMECC/OPECC) + + OMG0 = 2.*MAPL_PI/YEARLEN + OMG = OMG0/sqrt(OMSQECC)**3 + PRH = PERIHELION*D2R + SOB = sin(OBLIQUITY*D2R) + COB = cos(OBLIQUITY*D2R) + + ! PRH is the ecliptic longitude of the perihelion, measured (at the Sun) + ! from the autumnal equinox in the direction of the Earth`s orbital motion + ! (counterclockwise as viewed from ecliptic north pole). + ! For EOT calculations we will reference the perihelion wrt to the vernal + ! equinox, PRHV. Of course, the difference is just PI. + ! pmn: once the EOT code is established and zero-diff not an issue, + ! consider removing original PRH and changing the original (non-EOT), + ! code, which employs + ! cos(Y \pm PI) = -COS(Y) + ! to use PRHV, namely + ! -cos(Y-PRH) = cos(Y-PRH-PI) = cos(Y-PRHV) + PRHV = PRH + MAPL_PI_R8 + + ! Compute length of leap cycle + ! ---------------------------- + if(YEARLEN-int(YEARLEN) > 0.) then + YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) + else + YEARS_PER_CYCLE = 1 + endif + + DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) + + ! save inputs and intercalculation details + ! ---------------------------------------- + ORBIT%OB = OBLIQUITY + ORBIT%ECC = ECCENTRICITY + ORBIT%PER = PERIHELION + ORBIT%EQNX = EQUINOX + ORBIT%YEARLEN = YEARLEN + ORBIT%YEARS_PER_CYCLE = YEARS_PER_CYCLE + ORBIT%DAYS_PER_CYCLE = DAYS_PER_CYCLE + + ! Allocate orbital cycle outputs + ! ------------------------------ + ! TH: Ecliptic longitude of the true Sun, TREL [radians] + ! ZS: Sine of declination + ! ZC: Cosine of declination + ! PP: Inverse of square of earth-sun distance [1/(AU**2)] + ! ET: Equation of time [radians] = + ! True solar hour angle - Mean solar hour angle + + if(associated(ORBIT%TH)) deallocate(ORBIT%TH) + allocate(ORBIT%TH(DAYS_PER_CYCLE), stat=status) + _VERIFY(STATUS) - if(associated(ORBIT%ZC)) deallocate(ORBIT%ZC) - allocate(ORBIT%ZC(DAYS_PER_CYCLE), stat=status) - _VERIFY(STATUS) - - if(associated(ORBIT%ZS)) deallocate(ORBIT%ZS) - allocate(ORBIT%ZS(DAYS_PER_CYCLE), stat=status) - _VERIFY(STATUS) - - if(associated(ORBIT%PP)) deallocate(ORBIT%PP) - allocate(ORBIT%PP(DAYS_PER_CYCLE), stat=status) - _VERIFY(STATUS) + if(associated(ORBIT%ZC)) deallocate(ORBIT%ZC) + allocate(ORBIT%ZC(DAYS_PER_CYCLE), stat=status) + _VERIFY(STATUS) + + if(associated(ORBIT%ZS)) deallocate(ORBIT%ZS) + allocate(ORBIT%ZS(DAYS_PER_CYCLE), stat=status) + _VERIFY(STATUS) + + if(associated(ORBIT%PP)) deallocate(ORBIT%PP) + allocate(ORBIT%PP(DAYS_PER_CYCLE), stat=status) + _VERIFY(STATUS) + + if (ORBIT%EOT) then + if(associated(ORBIT%ET)) deallocate(ORBIT%ET) + allocate(ORBIT%ET(DAYS_PER_CYCLE), stat=status) + VERIFY_(STATUS) + end if + + ! Begin integration at the vernal equinox (K=1, KP=EQUINOX), at + ! which, by defn, the ecliptic longitude of the true sun is zero. + ! Right ascension of true sun at EQUINOX is also zero by defn. + ! -------------------------------------------------------------- + KP = EQUINOX + TREL = 0. + ORBIT%ZS(KP) = sin(TREL)*SOB + ORBIT%ZC(KP) = sqrt(1.-ORBIT%ZS(KP)**2) + ORBIT%PP(KP) = ( (1.-ECCENTRICITY*cos(TREL-PRH)) / OMSQECC )**2 + ORBIT%TH(KP) = TREL + + if (ORBIT%EOT) then + ! Right ascension of "mean sun" = MA(u) + PRHV [eqn (6) above]. + ! Calcn of True (TA), Eccentric (EA), and Mean Anomaly (MA). + TA = TREL - PRHV ! by defn of TA and PRHV + EA = 2.d0*atan(EAFAC*tan(TA/2.d0)) ! BM 4-55 + MA = EA - ECCENTRICITY*sin(EA) ! Kepler's eqn (BM 4-49 ff.) + MNRA = MA + PRHV ! see EOT notes above + TRRA = 0. ! because TREL=0 at Equinox + + ! Equation of Time, ET [radians] + ! True Solar hour angle = Mean Solar hour angle + ET + ! (hour angle and right ascension are in reverse direction) + ORBIT%ET(KP) = rect_pmpi(real(MNRA - TRRA)) + end if + + ! Integrate orbit for entire leap cycle using Runge-Kutta + ! Mean sun moves at constant speed around Celestial Equator + ! --------------------------------------------------------- + do K=2,DAYS_PER_CYCLE + T1 = dTRELdDAY(TREL ) + T2 = dTRELdDAY(TREL+T1*0.5) + T3 = dTRELdDAY(TREL+T2*0.5) + T4 = dTRELdDAY(TREL+T3 ) + KP = mod(KP,DAYS_PER_CYCLE) + 1 + TREL = TREL + (T1 + 2.0*(T2 + T3) + T4) / 6.0 + ORBIT%ZS(KP) = sin(TREL)*SOB + ORBIT%ZC(KP) = sqrt(1.-ORBIT%ZS(KP)**2) + ORBIT%PP(KP) = ( (1.-ECCENTRICITY*cos(TREL-PRH)) / OMSQECC )**2 + ORBIT%TH(KP) = TREL + if (ORBIT%EOT) then + ! From BM 1-15 and 1-16 with beta=0 (Sun is on ecliptic), + ! and dividing through by common cos(dec) since it does not + ! affect the ratio of sin(RA) to cos(RA). + TRRA = atan2(sin(TREL)*COB,cos(TREL)) + MNRA = MNRA + OMG0 + ORBIT%ET(KP) = rect_pmpi(real(MNRA - TRRA)) + end if + enddo + + ! enforce zero mean EOT (just in case) + if (ORBIT%EOT) then + meanEOT = sum(ORBIT%ET)/DAYS_PER_CYCLE + ORBIT%ET = ORBIT%ET - meanEOT + end if - ORBIT%CLOCK = CLOCK - ORBIT%OB = OBLIQUITY - ORBIT%ECC = ECCENTRICITY - ORBIT%PER = PERIHELION - ORBIT%EQNX = EQUINOX - ORBIT%YEARLEN = YEARLEN - ORBIT%YEARS_PER_CYCLE = YEARS_PER_CYCLE - ORBIT%DAYS_PER_CYCLE = DAYS_PER_CYCLE - -! TH: Orbit anomaly (radians) -! ZS: Sine of declination -! ZC: Cosine of declination -! PP: Inverse of square of earth-sun distance (1/(au**2)) - -! Begin integration at vernal equinox - - KP = EQUINOX - TT = 0.0 - ORBIT%ZS(KP) = sin(TT)*SOB - ORBIT%ZC(KP) = sqrt(1.0-ORBIT%ZS(KP)**2) - ORBIT%PP(KP) = ( ( 1.0-ECCENTRICITY*cos(TT-PRH) ) & - / ( 1.0-ECCENTRICITY**2 ) )**2 - ORBIT%TH(KP) = TT - -! Integrate orbit for entire leap cycle using Runge-Kutta - - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ORBIT%ZS(KP) = sin(TT)*SOB - ORBIT%ZC(KP) = sqrt(1.0-ORBIT%ZS(KP)**2) - ORBIT%PP(KP) = ( ( 1.0-ECCENTRICITY*cos(TT-PRH) ) & - / ( 1.0-ECCENTRICITY**2 ) )**2 - ORBIT%TH(KP) = TT - enddo + end if if (present(FIX_SUN)) then ORBIT%FIX_SUN=FIX_SUN @@ -245,6 +745,7 @@ type(MAPL_SunOrbit) function MAPL_SunOrbitCreate(CLOCK, & ORBIT%FIX_SUN=.FALSE. end if + ORBIT%CREATED = .TRUE. MAPL_SunOrbitCreate = ORBIT _RETURN(ESMF_SUCCESS) @@ -271,12 +772,13 @@ subroutine MAPL_SunOrbitDestroy(ORBIT, RC) !EOP character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitDestroy" - integer :: STATUS if(associated(ORBIT%TH)) deallocate(ORBIT%TH) if(associated(ORBIT%ZC)) deallocate(ORBIT%ZC) if(associated(ORBIT%ZS)) deallocate(ORBIT%ZS) if(associated(ORBIT%PP)) deallocate(ORBIT%PP) + if(associated(ORBIT%ET)) deallocate(ORBIT%ET) + ORBIT%CREATED = .FALSE. _RETURN(ESMF_SUCCESS) @@ -306,9 +808,8 @@ logical function MAPL_SunOrbitCreated(ORBIT, RC) !EOPI character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreated" - integer :: STATUS - MAPL_SunOrbitCreated = associated(ORBIT%TH) + MAPL_SunOrbitCreated = ORBIT%CREATED _RETURN(ESMF_SUCCESS) return @@ -339,6 +840,9 @@ subroutine MAPL_SunOrbitQuery(ORBIT, & CLOCK, & ZS, & ZC, & + TH, & + PP, & + ET, & RC ) ! !ARGUMENTS: @@ -354,15 +858,22 @@ subroutine MAPL_SunOrbitQuery(ORBIT, & type(ESMF_Clock ), optional, intent(OUT) :: CLOCK real, optional, pointer, dimension(:) :: ZS real, optional, pointer, dimension(:) :: ZC + real, optional, pointer, dimension(:) :: TH + real, optional, pointer, dimension(:) :: PP + real, optional, pointer, dimension(:) :: ET integer, optional, intent(OUT) :: RC +! BUGS: +! Not updated for ORBIT_ANAL2B option, which does not precalc +! many of the above outputs. + !EOPI character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitQuery" integer :: STATUS - _ASSERT(MAPL_SunOrbitCreated(ORBIT,RC=STATUS),'needs informative message') + _ASSERT(MAPL_SunOrbitCreated(ORBIT,RC=STATUS),'MAPL_SunOrbit not yet created!') if(present(CLOCK )) CLOCK = ORBIT%CLOCK if(present(OBLIQUITY )) OBLIQUITY = ORBIT%OB @@ -374,6 +885,9 @@ subroutine MAPL_SunOrbitQuery(ORBIT, & if(present(YEARS_PER_CYCLE)) YEARS_PER_CYCLE = ORBIT%YEARS_PER_CYCLE if(present(ZS )) ZS => ORBIT%ZS if(present(ZC )) ZC => ORBIT%ZC + if(present(TH )) TH => ORBIT%TH + if(present(PP )) PP => ORBIT%PP + if(present(ET )) ET => ORBIT%ET _RETURN(ESMF_SUCCESS) @@ -425,11 +939,17 @@ end subroutine MAPL_SunOrbitQuery ! MAPL_SunDailyMean ! MAPL_SunAnnualMean !\end{verbatim} +! +! Note: if ORBIT%EOT is .TRUE., an Equation of Time correction will be +! applied. This shifts the actual daylight period w.r.t. to mean solar +! noon, to account for small but cumulative eccentricity and obliquity +! effects on the actual length of the solar day. ! !INTERFACE: ! subroutine MAPL_SunGetInsolation(LONS, LATS, ORBIT,ZTH,SLR,INTV,CLOCK, & -! TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN, RC) +! TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN, & +! RC) ! !ARGUMENTS: @@ -460,7 +980,8 @@ end subroutine MAPL_SunOrbitQuery #define DIMENSIONS (:) #define THE_SIZE (size(LONS,1)) recursive subroutine SOLAR_1D(LONS, LATS, ORBIT,ZTH,SLR,INTV,CLOCK, & - TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN,STEPSIZE,RC) + TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN,& + STEPSIZE,RC) #include "sun.H" end subroutine SOLAR_1D @@ -471,7 +992,8 @@ end subroutine SOLAR_1D #define DIMENSIONS (:,:) #define THE_SIZE (size(LONS,1),size(LONS,2)) recursive subroutine SOLAR_2D(LONS, LATS, ORBIT,ZTH,SLR,INTV,CLOCK, & - TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN,STEPSIZE,RC) + TIME,currTime,DIST,ZTHB,ZTHD,ZTH1,ZTHN,& + STEPSIZE,RC) #include "sun.H" end subroutine SOLAR_2D #undef DIMENSIONS @@ -516,6 +1038,8 @@ subroutine SOLAR_ARR_INT(LONS, LATS, ORBIT, ZTH, SLR, INTV, CLOCK, & ! Begin + ASSERT_(.FALSE.) ! pmn: this routine is not up to date, is it even used anywhere? + call ESMF_ArrayGet(LONS, RANK=RANK, RC=STATUS) _VERIFY(STATUS) @@ -602,9 +1126,6 @@ subroutine GETIDAY(IDAY,TIME,ORBIT,RC) type(MAPL_SunORBIT), intent(IN ) :: ORBIT integer, optional, intent(OUT) :: RC - character(len=ESMF_MAXSTR) :: IAm = "GetIDAY" - integer :: STATUS - real :: ANOMALY select case(TIME) @@ -639,7 +1160,6 @@ subroutine MAPL_SunGetSolarConstantByTime(Time,SC,HK,rc) integer :: YY, DOY integer :: STATUS - character(len=ESMF_MAXSTR) :: IAm = "MAPL_SunGetSolarConstantByTime" call ESMF_TimeGet (TIME, YY=YY, DayOfYear=DOY, RC=STATUS) _VERIFY(STATUS) @@ -686,8 +1206,7 @@ subroutine MAPL_SunGetSolarConstantByYearDoY(year,dayofyear,SC,HK, rc) integer, optional, intent(OUT) :: rc real :: F - integer :: i1,i2,Current, STATUS - character(len=ESMF_MAXSTR) :: IAm = "MAPL_SunGetSolarConstantByYearDoY" + integer :: i1,i2,Current integer, parameter :: firstYear = 1610 integer, parameter :: finalYear = 2008 @@ -1468,9 +1987,9 @@ subroutine MAPL_SunGetSolarConstantByYearDoY(year,dayofyear,SC,HK, rc) HK(6) = ChouBand6(i1)*(1.-F) + ChouBand6(i2)*F HK(7) = ChouBand7(i1)*(1.-F) + ChouBand7(i2)*F HK(8) = ChouBand8(i1)*(1.-F) + ChouBand8(i2)*F - _ASSERT(abs(1.0-sum(HK))<1.e-4,'needs informative message') + _ASSERT(abs(1.0-sum(HK))<1.e-4,'Chou Solar band weightings do not sum to unity!') else - _ASSERT(.false.,'needs informative message') + _ASSERT(.false.,'HK: Solar band weightings only available for Chou') endif end if @@ -1509,9 +2028,8 @@ subroutine MAPL_SunGetSolarConstantFromNetcdfFile(CLOCK,fileName,SC,HK,MESOPHOT, real, optional, intent(out) :: JCALC4(:) integer, optional, intent(out) :: rc - type(ESMF_VM) :: VM type(ESMF_Time) :: time - integer :: i, k, N + integer :: N integer :: begYear, endYear integer :: INDX1, INDX2 integer :: MM, YY, DD, CCYY @@ -1545,7 +2063,6 @@ subroutine MAPL_SunGetSolarConstantFromNetcdfFile(CLOCK,fileName,SC,HK,MESOPHOT, real, dimension(:,:), allocatable :: coef_jcalc4 integer :: varid_coef_jcalc4 - character(len=ESMF_MAXSTR) :: shortName character(len=ESMF_MAXSTR) :: IAm = "MAPL_SunGetSolarConstantFromNetcdfFile" ! Open the file @@ -1900,8 +2417,7 @@ subroutine MAPL_SunGetSolarConstantFromNRLFile(CLOCK,filename_in,SC,MG,SB,Persis type(ESMF_Time) :: startCycle23, startCycle24 type(ESMF_TimeInterval) :: timeSinceStartOfCycle24 - integer :: currentYear, currentMon, currentDay, currentDOY, & - prevDay, nextDay + integer :: currentYear, currentMon, currentDay, currentDOY integer :: prevDOY, nextDOY, prevNoonYear, nextNoonYear integer :: originalYear, originalMon, originalDay, origDOY @@ -1930,8 +2446,6 @@ subroutine MAPL_SunGetSolarConstantFromNRLFile(CLOCK,filename_in,SC,MG,SB,Persis real, save, allocatable, dimension(:) :: tsi, mgindex, sbindex integer, save :: numlines - character(len=ESMF_MAXSTR) :: IAm = "MAPL_SunGetSolarConstantFromNRLFile" - if (present(PersistSolar)) then PersistSolar_ = PersistSolar else @@ -2282,4 +2796,198 @@ end function find_file_index end subroutine MAPL_SunGetSolarConstantFromNRLFile +!========================================================================== + +!BOPI + +! !IROUTINE: MAPL_SunGetDaylightDuration + +! !DESCRIPTION: + +! Return the daylight duration in seconds (i.e, the time between sunrise and sunset) for +! a day around the specified time. The routine is accurate enough for most purposes, but +! does not solve for precise sunrise/sunset times influenced by changes in the orbital +! parameters between those times. The time input does NOT need to be noon --- it is used +! simply to evaluate the solar declination needed for the daylight duration calculation. +! In order of preference, time is taken from currTime, if present, or else the currTime +! of CLOCK, if present, or else the currTime of the ORBIT's associated clock. + +! !INTERFACE: + + subroutine MAPL_SunGetDaylightDuration(ORBIT,LATS,DAYL,currTime,CLOCK,RC) + +! !ARGUMENTS: + + type(MAPL_SunOrbit), intent(IN ) :: ORBIT + real, dimension(:) , intent(IN ) :: LATS + real, dimension(:) , intent(OUT) :: DAYL + type(ESMF_Time) , optional, intent(IN ) :: currTime + type(ESMF_Clock) , optional, intent(IN ) :: CLOCK + integer, optional, intent(OUT) :: RC + +!EOPI + +! Locals + + character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_SunGetDaylightDuration" + integer :: STATUS + + type(ESMF_Time) :: CURRENTTIME + integer :: YEAR, SEC_OF_DAY, DAY_OF_YEAR, IDAY, IDAYP1 + real :: FAC, ZS, ZC + + real(ESMF_KIND_R8) :: days + real :: ECC, OBQ, LAMBDAP + real :: OMECC, OPECC, OMSQECC, EAFAC + real :: MA, EA, dE, TA, LAMBDA + integer :: nits + +! Begin + + _ASSERT(MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') + + ! which current time? + if (present(currTime)) then + CURRENTTIME = CURRTIME + else + if (present(CLOCK)) then + call ESMF_ClockGet( CLOCK, currTime=CURRENTTIME, RC=STATUS) + else + call ESMF_ClockGet(ORBIT%CLOCK, currTime=CURRENTTIME, RC=STATUS) + end if + _VERIFY(STATUS) + end if + + if (ORBIT%ANAL2B) then + + ! include time variation in orbit from reference time + call ESMF_TimeIntervalGet( & + CURRENTTIME - ORBIT%ORB2B_TIME_REF, & + d_r8=days, rc=STATUS) + _VERIFY(STATUS) + 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( & + CURRENTTIME - ORBIT%ORB2B_TIME_PERI, & + d_r8=days, rc=STATUS) + _VERIFY(STATUS) + ! 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 + ! sin and cos of solar declination + ZS = sin(LAMBDA) * sin(OBQ) + ZC = sqrt(1. - ZS**2) + + else + + call ESMF_TimeGet(CURRENTTIME, YY=YEAR, S=SEC_OF_DAY, & + dayOfYear=DAY_OF_YEAR, RC=STATUS) + _VERIFY(STATUS) + + YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) + IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR + IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 + + FAC = real(SEC_OF_DAY)/86400. + ZS = ORBIT%ZS(IDAYP1)*FAC + ORBIT%ZS(IDAY)*(1.-FAC) + ZC = ORBIT%ZC(IDAYP1)*FAC + ORBIT%ZC(IDAY)*(1.-FAC) + + endif + + ! dayligt duration [secs] + DAYL = (86400./MAPL_PI)*acos(min(1.,max(-1.,-tan(LATS)*ZS/ZC))) + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_SunGetDaylightDuration + +!========================================================================== + +!BOPI + +! !IROUTINE: MAPL_SunGetDaylightDurationMax + +! !DESCRIPTION: + +! Return the daylight duration in seconds (i.e, the time between sunrise and sunset) for +! its MAXIMUM at the summer solstice. The routine is accurate enough for most purposes, +! but does not solve for precise sunrise/sunset times influenced by changes in the orbital +! parameters between those times. The time input does NOT need to be noon --- it is used +! simply to evaluate the obliquity needed for the maximum daylight duration calculation. +! In order of preference, time is taken from currTime, if present, or else the currTime +! of CLOCK, if present, or else the currTime of the ORBIT's associated clock. +! Note: Unless ORBIT_ANAL2B, the obliquity is fixed and the time is irrelevant. + +! !INTERFACE: + + subroutine MAPL_SunGetDaylightDurationMax(ORBIT,LATS,DAYL,currTime,CLOCK,RC) + +! !ARGUMENTS: + + type(MAPL_SunOrbit), intent(IN ) :: ORBIT + real, dimension(:) , intent(IN ) :: LATS + real, dimension(:) , intent(OUT) :: DAYL + type(ESMF_Time) , optional, intent(IN ) :: currTime + type(ESMF_Clock) , optional, intent(IN ) :: CLOCK + integer, optional, intent(OUT) :: RC + +!EOPI + + character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_SunGetDaylightDurationMax" + integer :: STATUS + + type(ESMF_Time) :: CURRENTTIME + real(ESMF_KIND_R8) :: days + real :: OBQ + + _ASSERT(MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') + + ! Which time? + if (present(currTime)) then + CURRENTTIME = CURRTIME + else + if (present(CLOCK)) then + call ESMF_ClockGet( CLOCK, currTime=CURRENTTIME, RC=STATUS) + else + call ESMF_ClockGet(ORBIT%CLOCK, currTime=CURRENTTIME, RC=STATUS) + end if + _VERIFY(STATUS) + end if + + if (ORBIT%ANAL2B) then + ! time variation in obliquity from ref time + call ESMF_TimeIntervalGet( & + CURRENTTIME - ORBIT%ORB2B_TIME_REF, & + d_r8=days, rc=STATUS) + _VERIFY(STATUS) + OBQ = ORBIT%ORB2B_OBQ_REF + days * ORBIT%ORB2B_OBQ_RATE + else + ! obliquity fixed in this case + OBQ = ORBIT%OB * (MAPL_PI/180.) + endif + _ASSERT(0. <= OBQ .and. OBQ < MAPL_PI, 'Strange obliquity!') + + ! Maximum daylight duration at summer solstice [secs] + ! (an even function of latitude) + DAYL = (86400./MAPL_PI)*acos(min(1.,max(-1., & + -tan(ABS(LATS))*tan(OBQ)))) + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_SunGetDaylightDurationMax + +!========================================================================== + end module MAPL_SunMod diff --git a/MAPL_Base/Regrid_Functions_Mod.F90 b/MAPL_Base/Regrid_Functions_Mod.F90 index 2fac4a4c7804..2aa95bd4b587 100644 --- a/MAPL_Base/Regrid_Functions_Mod.F90 +++ b/MAPL_Base/Regrid_Functions_Mod.F90 @@ -1,3 +1,5 @@ +#include "unused_dummy.H" + !----------------------------------------------------------------------- ! GEOS-Chem Global Chemical Transport Model ! !----------------------------------------------------------------------- @@ -180,8 +182,6 @@ Subroutine Set_fID(fIDIn, fIDOut, RC) ! ! !LOCAL VARIABLES: ! - Character(Len=255) :: OutMsg - !================================================================= ! Set_fID starts here! !================================================================= @@ -241,8 +241,6 @@ Subroutine Cleanup(RC) ! ! !LOCAL VARIABLES: ! - Character(Len=255) :: OutMsg - !================================================================= ! Cleanup starts here! !================================================================= @@ -307,7 +305,7 @@ subroutine readTileFileNC(TFDir,gridIn,gridOut,RC) ! ! !LOCAL VARIABLES: ! - Character(Len=255) :: fName, errMsg + Character(Len=255) :: fName Logical :: Found Integer :: status @@ -354,7 +352,7 @@ subroutine readTileFileNC_file(fName, RC) ! Expected grid sizes - Integer :: resIn(2), resOut(2) + !Integer :: resIn(2), resOut(2) ! Grid sizes on file integer :: resInFile(2), resOutFile(2) @@ -567,6 +565,8 @@ Subroutine transposeCS(II,JJ,nX,nY,nVal,iFace) Integer :: JJ0(nVal) Integer :: I + _UNUSED_DUMMY(nY) + ! Copy input II0 = II JJ0 = JJ @@ -597,6 +597,8 @@ Subroutine flipCS(II,JJ,nX,nY,nVal,iFace,iDir) Integer :: I Logical :: flipII, flipJJ + _UNUSED_DUMMY(nY) + ! Copy input II0 = II JJ0 = JJ @@ -628,9 +630,10 @@ Subroutine swapCS(II,JJ,nX,nY,nVal) Integer :: II0(nVal) Integer :: JJ0(nVal) Integer :: I - Logical :: flipII, flipJJ Integer, Parameter :: faceMap(6) = (/4,5,1,2,6,3/) + _UNUSED_DUMMY(nY) + ! Copy input II0 = II JJ0 = JJ @@ -922,6 +925,8 @@ Subroutine genGridName(nX, nY, gridName, xVec, yVec, & Logical :: isDE_ Logical :: isPC_ + _UNUSED_DUMMY(rc) + !================================================================= ! genGridName starts here! !================================================================= @@ -1169,7 +1174,7 @@ Subroutine nXYtoVec(xVec,yVec,isCS,isPC,isDE,RC) ! Integer :: nX, nY Integer :: I, RC_ - Real(sp) :: fTemp, fMin, fMax, fStride + Real(sp) :: fMin, fStride !================================================================= ! nXYtoVec starts here! @@ -1328,7 +1333,7 @@ Subroutine regridData(in2D,out2D,RC) ! !LOCAL VARIABLES: ! Integer :: I, iX, iY - Real(kind=sp) :: wVal, inVal, outVal, rCount + Real(kind=sp) :: wVal, inVal, outVal Real(kind=sp), Parameter :: missingVal=0.0 !================================================================= @@ -1406,9 +1411,9 @@ Subroutine ReadInput(resOut,fNameIn,fNameOut,reverseLev,& ! ! !LOCAL VARIABLES: ! - Integer :: fIDGCHP, RC_, IOS, nRead, I + Integer :: fIDGCHP, RC_, I Integer :: resTemp(2) - Character(Len=255) :: currLine, strRead, leftStr, rightStr + Character(Len=255) :: currLine, strRead Logical :: Found, logRead !================================================================= diff --git a/MAPL_Base/Regrid_Util.F90 b/MAPL_Base/Regrid_Util.F90 index e57fbf0e9036..98bfa50dfd3f 100644 --- a/MAPL_Base/Regrid_Util.F90 +++ b/MAPL_Base/Regrid_Util.F90 @@ -510,6 +510,9 @@ subroutine simpleDynMaskProc(dynamicMaskList, dynamicSrcMaskValue, & integer, intent(out) :: rc integer :: i, j real(ESMF_KIND_R8) :: renorm + + _UNUSED_DUMMY(dynamicDstMaskValue) + if (associated(dynamicMaskList)) then do i=1, size(dynamicMaskList) dynamicMaskList(i)%dstElement = 0.d0 ! set to zero @@ -751,7 +754,6 @@ function create_grid(grid_type,gname,im_world,jm_world,lm,nx,ny,dateline,pole,tp integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam = "create_grid" type(LatLonGridFactory) :: ll_factory select case(grid_type) diff --git a/MAPL_Base/allgather.H b/MAPL_Base/allgather.H index 3ab536b8faf5..d0066ff4be3f 100644 --- a/MAPL_Base/allgather.H +++ b/MAPL_Base/allgather.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/allgatherv.H b/MAPL_Base/allgatherv.H index 780026fda558..2aa475833405 100644 --- a/MAPL_Base/allgatherv.H +++ b/MAPL_Base/allgatherv.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/allreducemax.H b/MAPL_Base/allreducemax.H index ef565dc435fa..ce991bafbf10 100755 --- a/MAPL_Base/allreducemax.H +++ b/MAPL_Base/allreducemax.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/allreducemin.H b/MAPL_Base/allreducemin.H index 212ae2e14dcf..3e7cb4366e06 100755 --- a/MAPL_Base/allreducemin.H +++ b/MAPL_Base/allreducemin.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/allreducesum.H b/MAPL_Base/allreducesum.H index 8995394c7661..1cbeed251b3b 100755 --- a/MAPL_Base/allreducesum.H +++ b/MAPL_Base/allreducesum.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/arraygather.H b/MAPL_Base/arraygather.H index d2981ce16e33..26a94ee48064 100644 --- a/MAPL_Base/arraygather.H +++ b/MAPL_Base/arraygather.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -25,7 +24,6 @@ ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='ArrayGather' type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid diff --git a/MAPL_Base/arraygatherRcvCnt.H b/MAPL_Base/arraygatherRcvCnt.H index 891167018994..6f52b1627e38 100644 --- a/MAPL_Base/arraygatherRcvCnt.H +++ b/MAPL_Base/arraygatherRcvCnt.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -24,7 +23,6 @@ ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='ArrayGatherRcvCnt' integer, allocatable, dimension(:) :: displs integer :: nDEs diff --git a/MAPL_Base/arrayscatter.H b/MAPL_Base/arrayscatter.H index cf9d2a606869..3b32f69d5cc7 100644 --- a/MAPL_Base/arrayscatter.H +++ b/MAPL_Base/arrayscatter.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -28,7 +27,6 @@ ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='ArrayScatter' TYPE_(kind=EKIND_), pointer :: myglob DIMENSIONS_ => null() TYPE_(kind=EKIND_), pointer :: VAR(:) diff --git a/MAPL_Base/arrayscatterRcvCnt.H b/MAPL_Base/arrayscatterRcvCnt.H index e0b4a811dc48..a9c372d59556 100644 --- a/MAPL_Base/arrayscatterRcvCnt.H +++ b/MAPL_Base/arrayscatterRcvCnt.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -24,7 +23,6 @@ ! Local variables integer :: status - character(len=ESMF_MAXSTR) :: IAm='ArrayScatterRcvCnt' integer, allocatable, dimension(:) :: displs integer :: nDEs diff --git a/MAPL_Base/bcast.H b/MAPL_Base/bcast.H index 4dec82d9a471..6be76af425a1 100644 --- a/MAPL_Base/bcast.H +++ b/MAPL_Base/bcast.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/gather.H b/MAPL_Base/gather.H index 21a4ce9b4290..b525601dca4f 100644 --- a/MAPL_Base/gather.H +++ b/MAPL_Base/gather.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/hash.c b/MAPL_Base/hash.c index db1a436689e7..983f0d0f680e 100644 --- a/MAPL_Base/hash.c +++ b/MAPL_Base/hash.c @@ -1,5 +1,4 @@ -// $Id$ #ifndef sysAIX #include @@ -39,7 +38,7 @@ void init_hash(hash_t *h, int nbuckets) { h->bucket_list = (bucket_t *)malloc((size_t)(nbuckets*sizeof(bucket_t))); if(!h->bucket_list) { - printf("hash.c $Name$ line=%d : Could not allocate bucket list\n",__LINE__); + printf("hash.c line=%d : Could not allocate bucket list\n",__LINE__); exit(1); } for(l=0; lnext_entry = 0; b->entry_list = (entry_t *)malloc((size_t)(b->size*sizeof(entry_t))); if(!b->entry_list) { - printf("hash.c $Name$ line=%d : Could not allocate entry list\n",__LINE__); + printf("hash.c line=%d : Could not allocate entry list\n",__LINE__); exit(1); } } @@ -72,7 +71,7 @@ int create_hash(int nbuckets) if(!hash_heap) { hash_heap = (hash_t *)malloc(hash_heap_size*sizeof(hash_t)); if(!hash_heap) { - printf("hash.c $Name$ line=%d : Could not allocate hash_heap\n",__LINE__); + printf("hash.c line=%d : Could not allocate hash_heap\n",__LINE__); exit(1); } for(i=0;ientry_list = (entry_t *)realloc(bucket->entry_list,sizeof(entry_t)*bucket->size); if(!bucket->entry_list) { - printf("hash.c $Name$ %d : Could not reallocate entry list\n",__LINE__); + printf("hash.c line=%d : Could not reallocate entry list\n",__LINE__); exit(1); } } diff --git a/MAPL_Base/orbit.pdf b/MAPL_Base/orbit.pdf new file mode 100644 index 000000000000..e97bfea6ae31 Binary files /dev/null and b/MAPL_Base/orbit.pdf differ diff --git a/MAPL_Base/orbit.tex b/MAPL_Base/orbit.tex new file mode 100644 index 000000000000..28089ff12cb0 --- /dev/null +++ b/MAPL_Base/orbit.tex @@ -0,0 +1,533 @@ +\documentclass[]{AGUJournal} + +\usepackage{amsmath,amssymb} +\usepackage[mathcal]{euscript} + +\newcommand{\beq}{\begin{equation}} +\newcommand{\eeq}{\end{equation}} +\newcommand{\earth}{{\mathcal{E}}} +\newcommand{\sun}{{\mathcal{S}}} +\newcommand{\mqsun}{{\mathcal{M}}} +\newcommand{\mearth}{{\mathcal{Q}}} +\renewcommand{\center}{{\mathcal{O}}} +\newcommand{\peri}{{\mathcal{P}}} +\newcommand{\aphe}{{\mathcal{A}}} +\newcommand{\fpoa}{\Upsilon} +\newcommand{\Tsid}{T_*} +\newcommand{\Tmsol}{T_\mqsun} +\newcommand{\al}{\alpha} +\newcommand{\la}{\lambda} +\newcommand{\eps}{\varepsilon} +\newcommand{\cob}{{\cos\eps}} +\newcommand{\sob}{{\sin\eps}} +\DeclareMathOperator{\atan2}{atan2} +\DeclareMathOperator{\artanh}{artanh} +\DeclareMathOperator{\sgn}{sgn} +\newcommand{\dee}{\text{d}} +\newcommand{\du}{\dee u} +\newcommand{\dE}{\dee E} +\newcommand{\dM}{\dee M} +\newcommand{\dla}{\dee \la} +\newcommand{\dnu}{\dee \nu} +\newcommand{\MA}{M\!A} +\newcommand{\TA}{T\!A} +\renewcommand{\circle}{{\mathcal{C}}} +\newcommand{\commentout}[1]{} + +\begin{document} + +\title{Equation of Time} + +\authors{Peter M. Norris\affil{1,2}} + +\affiliation{1}{University Space Research Association, +Columbia, Maryland, USA} +\affiliation{2}{Global Modeling and Assimilation Office, +NASA GSFC, Greenbelt, Maryland, USA} + +\correspondingauthor{P. M. Norris, +Global Modeling and Assimilation Office, +NASA/GSFC, Code 610.1, Greenbelt, MD 20771, +USA}{peter.m.norris@nasa.gov} + +\section{Introduction} + +The earth rotates on its axis with a period $\Tsid$ called the {\em sidereal day} (after the Latin for ``star'', since it is the rotation period +of the earth with respect to distant stars). $\Tsid$ is slightly shorter than the so-called {\em mean solar day}, or clock day, of duration +$\Tmsol =$ 86400 seconds. This is because the earth is a prograde planet, that is, it rotates about its axis in the same sense +(counterclockwise looking down on the North Pole) as it orbits the sun. Specifically, say the sun crosses the meridian of some location +at a particular time. And imagine there is a distant star directly behind the sun at that moment. After one sidereal day the location will +rotate 360$^\circ$ about the earth's axis and the distant star will again cross its meridian. But during that time the earth will have +moved a small counterclockwise distance around its orbit and so it will take a small additional rotation of the earth for the sun to also +cross the meridian and thereby complete a {\em solar day}. + +Put another way, a solar day is slightly longer than a sidereal day because the sun appears to move slowly eastward across the +celestial sphere with respect to distant stars as the year passes. The path of this motion is called the {\em ecliptic}. Clearly, what +governs the length of a solar day is the apparent velocity of the sun along the ecliptic, or, more particularly, the equatorial component +of that velocity. But both the magnitude and equatorial component of the solar ecliptic velocity change during the year, the former +because the earth's orbit is elliptical, not circular, and the latter because the earth's axis of rotation is tilted with respect to the orbital +(ecliptic) plane. Thus the length of a solar day changes during the year. While these factors cause only a small perturbation to the +length of the solar day (less than 30 seconds), the perturbations accumulate so that, at different times of the year, apparent solar time +(``sundial time'') and mean solar time (``clock time'') can differ by as much as about 15 minutes. This difference is called the Equation +of Time. + +To be more rigorous, in the sequel, let $\earth$ denote the earth, $\sun$ the true sun, and $\mqsun$ a fictitious ``mean sun'' that moves +{\em at constant eastward speed around the celestial equator}, completing a full orbit in a year, namely in the period $Y \,\Tmsol$, where $Y$ +is the number of mean solar days in a year (e.g., 365.25). Thus, in one mean solar day, $\Tmsol$, the mean sun has moved an angle $2\pi/Y$ +eastward. Hence, beyond one full earth revolution, period $\Tsid$, an additional earth rotation of $(\Tmsol-\Tsid) \, 2\pi/\Tsid = 2\pi/Y$ is required +to ``catch up with the moving sun'', as described earlier. Hence $\Tmsol - \Tsid = \Tsid / Y$ and so +\beq +\Tmsol = \Tsid \, \frac{Y+1}{Y}, +\label{eq:TMTS} +\eeq +a constant (near unity) multiple of the fixed sidereal day. $\Tmsol$ is the length of the solar day for the ``mean sun'', or the ``mean solar day''. +Because it is invariant during the year, it is convenient for timekeeping, and forms the basis for ``mean solar time'', which at Greenwich is +essentially UTC. By {\em definition}, $\Tmsol$ = 24h = 86400s. That is, what we know as ``hours'', ``minutes'' and ``seconds'', are just +convenient integer fractions of the mean solar day. In these units, the sidereal day $\Tsid$ is approximately 23h 56m 4s. + +The solar zenith angle calculation (in {\tt MAPL\_sunGetInsolation}) needs the {\em local solar hour angle}, $h_\sun$, which is the angle, +measured westward along the equator, from the local meridian to the sun. This is just the {\em Greenwich solar hour angle}, $H_\sun$, +plus the longitude, so we will henceforth work exclusively with Greenwich hour angles. We should use the hour angle of the true sun, +$H_\sun$, but a common approximation replaces this with the hour angle of the mean sun +\beq +H_\mqsun = 2\pi\,(u - 1/2), +\label{eq:HM} +\eeq +where $u$ is UTC time (in days) and the offset is needed because the mean solar hour angle is zero at ``noon''. If more accuracy is +required, the hour angle of the true sun is typically obtained as a small correction to $H_\mqsun$ called the Equation of time, $EOT$: +\beq +H_\sun = H_\mqsun + EOT, \quad\text{where}\quad EOT = H_\sun - H_\mqsun. +\label{eq:EOT-def} +\eeq +As discussed above, EOT corrects for two factors: +\begin{itemize} +\item[(a)]{} the variable speed of the earth in its elliptical orbit about the sun (e.g., moving fastest at perihelion), and +\item[(b)]{} the tilt of the earth's axis of rotation with respect to its orbital plane (the ``obliquity''), which causes the equatorial projection +of the sun's apparent ecliptic motion to vary with the season (e.g., being parallel to the equator at the solstices.) +\end{itemize} + +\section{Derivation of Equation of Time} + +We can write +\beq +H_\sun = H_\fpoa - (H_\fpoa - H_\sun) = H_\fpoa - \al_\sun, +\eeq +where $H_\fpoa$ is the Greenwich hour angle of the First Point of Aries (the location of the vernal equinox, denoted $\fpoa$) and is also +known as the Greenwich sidereal hour angle, and where $\al_\sun$ is the right ascension of the true sun (since the right ascension of +any object is just the difference between the hour angles of $\fpoa$ and the object). Hence, +\beq +EOT = H_\fpoa - H_\mqsun - \al_\sun. +\label{eq:EOT} +\eeq +All three terms on the right of (\ref{eq:EOT}) are time variable: $\al_\sun$ changes slowly throughout the year, and is known from the earth-sun +two-body elliptical orbit solution, while $H_\fpoa$ and $H_\mqsun$ vary rapidly with Earth's rotation. $H_\mqsun$ has a period of one mean solar +day, $\Tmsol$, and $H_\fpoa$ has a period of one sidereal day, $T_S$. + +It may seem from from (\ref{eq:HM}) that the mean sun and its hour angle are fully specified. That, in fact, is not yet the case: (\ref{eq:HM}) is really +just a definition of UTC, namely, that one UTC day is one mean solar day and that the time of culmination of the mean sun, what we call ``noon'', +occurs at UTC 12h00m. What we are still at liberty to do is specify the phasing of the mean sun in its equatorial orbit, e.g., by specifying the time +$u_R$ at which the mean sun passes through $\fpoa$ (both on the equator). At this time, $H_\fpoa(u_R) = H_\mqsun(u_R)$, and so +\beq +\begin{split} +H_\fpoa(u) - H_\mqsun(u) +& = 2\pi\, (u - u_R)\,(Y+1)/Y - 2\pi\, (u - u_R) \\ +& = 2\pi\, (u - u_R) / Y\\ +& = \MA(u) - \MA(u_R), +\end{split} +\label{eq:EOT-h} +\eeq +where +\beq +\MA(u) \equiv 2\pi\, (u - u_\peri) / Y +\label{eq:MA} +\eeq +is the so-called ``mean anomaly'', known from the earth-sun two-body orbital solution, and $u_\peri$ is the time of perihelion. +Thus, to fully determine $EOT$, through (\ref{eq:EOT}) and (\ref{eq:EOT-h}), we need only to specify $\MA(u_R)$. + +To understand the mean anomaly $\MA$, consider the standard two-body earth-sun problem in which the earth $\earth$ moves in an elliptical +orbit about the sun $\sun$ at one focus, all in the {\em ecliptic plane}. The point on the ellipse closest to $\sun$ is called the perihelion $\peri$. +Obviously, the center of the ellipse $\center$, the focus $\sun$ and the perihelion $\peri$ are co-linear, the so-called major axis of the ellipse. +Additionally, let $\circle$ be the circumscribing circle of the ellipse, with center $\center$ and passing through $\peri$ (and the corresponding +aphelion $\aphe$). By Kepler's Second Law, the sun-earth vector sweeps out equal areas in equal times, so the {\em fractional area\/} of the +elliptical sector $\peri\sun\earth$ is a linear function of time, being zero at perihelion and one a year later. Specifically, this fractional area is +none other than the scaled mean anomaly $\MA(u) / (2\pi) = (u - u_\peri) / Y$ from (\ref{eq:MA}). Clearly $\MA(u)$ can also be interpreted as +an angle, the angle $\angle\peri\center\mearth$ of a point $\mearth$ orbiting on the circumcircle $\circle$ at constant speed in the same direction +as the earth, also with a yearly period, and passing through $\peri$ at the same time $u_\peri$ as the earth. Thus the point $\mearth$ can be +conceptualized as a sort of ``mean earth'' orbiting a ``second mean sun'' (different from $\mqsun$ above) at $\center$. Note that while the +angle $\MA(u) = \angle\peri\center\mearth$ of this mean earth at time $u$ is a linear function of time, the corresponding angle of the real earth, +namely $\TA(u) \equiv \angle\peri\sun\earth$, called the {\em true anomaly}, is a non-linear function of time, since the real earth has a variable +speed in its elliptical orbit, e.g., moving faster at perihelion, so that its {\em areal fraction\/} is linear in time. The relationship between $\MA(u)$ +and $\TA(u)$ is known from the orbital solution and will be discussed later. Finally, the {\em ecliptic longitude of the earth}, +$\la \equiv \angle\fpoa\sun\earth$ is the angle at the sun, measured in the same direction as the earth's motion, from the +First Point of Aries $\fpoa$ to the earth. Then +\beq +\TA(u) \equiv \angle\peri\sun\earth(u) = \angle\peri\sun\fpoa + \angle\fpoa\sun\earth(u) = \la(u) - \la_\peri, +\eeq +where $\la_\peri = \la(u_\peri) \equiv \angle\fpoa\sun\peri = -\angle\peri\sun\fpoa$ is known as the {\em longitude of perihelion}, and is currently about +$283^\circ$, or equivalently $-77^\circ$. + +With this background, we can understand the quantity $\MA(u_R)$ we are trying to specify. If we \textbf{\textit{choose}} +\beq +\MA(u_R) = - \la_\peri = \angle\peri\sun\fpoa \iff \angle\peri\center\mearth(u_R) = \angle\peri\sun\fpoa, +\label{eq:uR-choice} +\eeq +then at $u_R$, viewed from the mean earth $\mearth$, the second (ecliptic) mean sun $\center$ is in direction of $\fpoa$. +And at that same time, by definition of $u_R$, the first (equatorial) mean sun $\mqsun$, as seen from the real earth $\earth$, +is also in direction of $\fpoa$. + +\section{Integrals} + +Does this particular choice of $u_R$ gives zero mean $EOT$, as required for a {\em mean\/} solar time? +Let $\langle\cdot\rangle$ denote a time average over one orbit (one year), so that (\ref{eq:EOT}), (\ref{eq:EOT-h}) and (\ref{eq:uR-choice}) yield +\beq +\langle EOT \rangle += \langle \MA(u) \rangle + \la_\peri - \langle \al_\sun \rangle += \MA(\langle u \rangle) + \la_\peri - \langle \al_\sun \rangle, +\eeq +since $\MA$ is a linear function of $u$. +In particular, let +\beq +{\langle f \rangle}_X \equiv Y^{-1} \int_{X-Y/2}^{X+Y/2} f(u) \,\du, +\label{eq:tavg-def} +\eeq +whence +\beq +\langle EOT \rangle_{u_X} = \MA(u_X) + \la_\peri - \langle \al_\sun \rangle_{u_X}. +\label{eq:mEOT-gen} +\eeq +For example, +\beq +\langle EOT \rangle_{u_\peri} = \la_\peri - \langle \al_\sun \rangle_{u_\peri}, \quad\text{and}\quad +\langle EOT \rangle_{u_\fpoa} = \MA(u_\fpoa) + \la_\peri - \langle \al_\sun \rangle_{u_\fpoa}. +\label{eq:mEOT-eg} +\eeq +The right ascension of the true sun, $\al_\sun \in (-\pi,+\pi]$, is given by +\beq +\al_\sun = \atan2\,(\sin\la\,\cob, \cos\la), +\eeq +where $\eps$ be the earth's obliquity ($\approx 23.5^\circ$). Both $\la$ and $\al_\sun$ are zero at $\fpoa$. +To proceed, we will use the following rate of change of $\la$ from the two-body theory: +\beq +\frac{\dla}{\du} = \frac{\dnu}{\du} + = \frac{2\pi}{Y}\,(1-e^2)^{-3/2}\,(1 + e\cos\nu)^2, +\eeq +where $e$ is the eccentricity and $\nu \equiv \la(u) - \la_\peri$ is shorthand for the true anomaly of the earth, $\TA(u)$. +Then, without being precise on limits for now, +\beq +\langle \al_\sun \rangle += Y^{-1} \int \frac{\al_\sun \dla}{\dla / \du} += \int \frac{\atan2\,(\sin\la\,\cob, \cos\la)}{(1-e^2)^{-3/2}\,[1+e\cos(\la-\la_\peri)]^2} \frac{\dla}{2\pi}. +\eeq +Finally, just as $\fpoa$ denotes the location of the vernal equinox, $\la = \al_\sun = 0$, we will also use $\fpoa'$ to denote +the location of the autumnal equinox, $\la = \al_\sun = \pm \pi$. In general, $u_\fpoa - u_{\fpoa'}$ is not exactly half a year. + +\subsection{Zero obliquity} + +For the simple case where the obliquity is zero, $\cob=1$ and $\al_\sun = \la = \nu + \la_\peri$, and so +\beq +\begin{split} +\langle \al_\sun \rangle_{u_\peri} += & \int_{-\pi}^{+\pi} \frac{\nu+\la_\peri}{(1-e^2)^{-3/2}\,[1+e\cos\nu]^2} \frac{\dnu}{2\pi} \\ += & \frac{\la_\peri}{2\pi} \int_{-\pi}^{+\pi} \frac{\dnu}{(1-e^2)^{-3/2}\,[1+e\cos\nu]^2}, +\end{split} +\eeq +since perihelion and aphelion are half a year apart by symmetry and since the $\nu$ term is odd. +The true anomaly can be expressed in terms of the {\em eccentric anomaly\/} $E \in (-\pi,+\pi]$: +\beq +\cos\nu = \frac{\cos E - e}{1 - e \cos E} +\quad\text{and}\quad +\sin\nu = \frac{\sqrt{1 - e^2} \sin E}{1 - e \cos E}, +\eeq +whence +\beq +1 + e\cos\nu = \frac{1 - e^2}{1 - e \cos E}. +\eeq +and +\beq +-\sin\nu \frac{\dnu}{\dE} = -\sin E \frac{1 - e^2}{(1 - e \cos E)^2} +\implies \frac{\dnu}{\dE} = \frac{\sqrt{1 - e^2}}{1 - e \cos E} +\eeq +Hence, +\beq +\langle \al_\sun \rangle_{u_\peri} += \frac{\la_\peri}{2\pi} \int_{-\pi}^{+\pi} (1 - e \cos E) \,\dE = \frac{\la_\peri}{2\pi} \int_{-\pi}^{+\pi} \,\dM += \la_\peri. +\eeq +where $M \equiv E - e \sin E$. Hence, as required, $\langle EOT \rangle_{u_\peri} = 0$ by (\ref{eq:mEOT-eg}). +Note that $M(u)$ is none other than $\MA(u)$, as per Kepler's Equation of the two-body solution. + +\subsection{Zero eccentricity} + +For zero eccentricity, $e=0$, we get the simple form +\beq +\langle \al_\sun \rangle = \int \atan2\,(\sin\la\,\cob, \cos\la) \frac{\dla}{2\pi}, +\eeq +and, in particular, +\beq +\langle\al_\sun\rangle_{u_{\fpoa'}+Y/2} += \int_{u_{\fpoa'}}^{u_{\fpoa'}+Y} \hspace{-1em} \al_\sun(u) \frac{\du}{Y} += \int_{-\pi}^{+\pi} \!\! \atan2\,(\sin\la\,\cob, \cos\la) \frac{\dla}{2\pi} += 0, +\eeq +since since $\atan2$ is odd in $\la$. Then, by (\ref{eq:mEOT-gen}), +\beq +\langle EOT \rangle_{u_{\fpoa'}+Y/2} = \MA(u_{\fpoa'}+Y/2) + \la_\peri - \langle \al_\sun \rangle_{u_{\fpoa'}+Y/2} = \MA(u_\fpoa) + \la_\peri, +\eeq +since $\fpoa'$ and $\fpoa$ {\em are\/} a half year apart for a circular ($e=0$) orbit. But also for a circular orbit, $\MA(u) = \TA(u) = \la(u) - \la_\peri$, +so +\beq +\langle EOT \rangle_{u_{\fpoa'}+Y/2} = (\la(u_\fpoa) - \la_\peri) + \la_\peri = \la(u_\fpoa) \equiv 0, +\eeq +as required. + +\subsection{General case} + +For the general general case, +\beq +\begin{split} +\langle\al_\sun\rangle_{u_{\fpoa'}+Y/2} +& = \int_{u_{\fpoa'}}^{u_{\fpoa'}+Y} \hspace{-1em} \al_\sun \frac{\du}{Y} + = \int_{-\pi}^{+\pi} \!\! \frac{\atan2\,(\sin\la\,\cob, \cos\la)}{(1-e^2)^{-3/2}\,[1+e\cos(\la-\la_\peri)]^2} \frac{\dla}{2\pi} \\ +& = \int_0^{\pi} \frac{\atan2\,(\sin\la\,\cob, \cos\la)}{(1-e^2)^{-3/2}}D(\la; \la_\peri) \frac{\dla}{2\pi}, +\end{split} +\eeq +since $\atan2$ is odd in $\la$, where +\beq +\begin{split} +D(\la; \la_\peri) +& \equiv \frac{1}{[1+e\cos(\la - \la_\peri)]^2} - \frac{1}{[1+e\cos(\la + \la_\peri)]^2} \\ +& = \frac{[1+e\cos(\la + \la_\peri)]^2 - [1+e\cos(\la - \la_\peri)]^2}{[(1+e\cos(\la - \la_\peri))(1+e\cos(\la + \la_\peri))]^2} \\ +& = \frac{2e(\cos(\la + \la_\peri) - \cos(\la - \la_\peri)) + e^2(\cos^2(\la + \la_\peri) - \cos^2(\la - \la_\peri))}{[1 + e(\cos(\la - \la_\peri) + \cos(\la + \la_\peri)) + e^2 \cos(\la - \la_\peri) \cos(\la + \la_\peri)]^2} \\ +& = \frac{-4e\sin\la\sin\la_\peri - 4\,e^2\cos\la\cos\la_\peri\sin\la\sin\la_\peri }{[1 + 2e\cos\la\cos\la_\peri + e^2 (\cos^2\!\la\,\cos^2\!\la_\peri - \sin^2\!\la\,\sin^2\!\la_\peri)]^2} \\ +%& = \frac{ -4 e \sin\la\sin\la_\peri (1 + e\cos\la\cos\la_\peri) }{[1 + 2e\cos\la\cos\la_\peri + e^2 (\cos^2\!\la\,\cos^2\!\la_\peri - \sin^2\!\la\,\sin^2\!\la_\peri)]^2}. \\ +& = \frac{ -4 e \sin\la\sin\la_\peri (1 + e\cos\la\cos\la_\peri) }{[(1 + e\cos\la\cos\la_\peri)^2 - e^2 \sin^2\!\la\,\sin^2\!\la_\peri)]^2}. +\end{split} +\eeq +%\[ \cos(\la \pm \la_\peri) = \cos\la\cos\la_\peri \mp \sin\la\sin\la_\peri \] +%\[ \cos^2(\la \pm \la_\peri) = \cos^2\!\la\,\cos^2\!\la_\peri \mp 2\cos\la\cos\la_\peri\sin\la\sin\la_\peri + \sin^2\!\la\,\sin^2\!\la_\peri \] +%\[ \cos(\la + \la_\peri)\cos(\la - \la_\peri) = \cos^2\!\la\,\cos^2\!\la_\peri - \sin^2\!\la\,\sin^2\!\la_\peri \] +Continuing with the reduction, +\beq +\begin{split} +\langle& \al_\sun\rangle_{u_{\fpoa'}+Y/2} = \int_0^{\pi/2} \frac{\atan2\,(\sin\la\,\cob, \cos\la)}{(1-e^2)^{-3/2}}D(\la; \la_\peri) \\ +& \hspace{3cm} + \frac{\atan2\,(\cos\la\,\cob, -\sin\la)}{(1-e^2)^{-3/2}}D(\la\!+\!\pi/2; \la_\peri) \:\frac{\dla}{2\pi} \\ +& = \int_0^{\pi/2} \hspace{-1em} \arctan(\tan\la\,\cob) \frac{D(\la; \la_\peri)}{(1-e^2)^{-3/2}} + [\pi-\arctan(\cot\la\,\cob)] \frac{D(\la\!+\!\pi/2; \la_\peri)}{(1-e^2)^{-3/2}} \:\frac{\dla}{2\pi}, +\end{split} +\eeq +where +\beq +D(\la+\pi/2; \la_\peri) = \frac{ -4 e \cos\la\sin\la_\peri (1 - e\sin\la\cos\la_\peri) }{[(1 - e\sin\la\cos\la_\peri)^2 - e^2 \cos^2\!\la\,\sin^2\!\la_\peri)]^2}. +\eeq + +We will attempt a solution by expanding in powers of $e$, since $e \approx 0.0167 \ll 1$. +Clearly for $e=0$ both $D$ terms are zero and we get our earlier special case result. + +\subsubsection{First order in $e$} + +To {\em first\/} order in $e$: +\beq +\frac{D(\la; \la_\peri)}{(1-e^2)^{-3/2}} \approx -4 e \sin\la\sin\la_\peri, \quad +\frac{D(\la+\pi/2; \la_\peri)}{(1-e^2)^{-3/2}} \approx -4 e \cos\la\sin\la_\peri, +\eeq +and so +\beq +\begin{split} +\langle& \al_\sun\rangle_{u_{\fpoa'}+Y/2} \\ +& \approx -4 \, e \sin\la_\peri \int_0^{\pi/2} \hspace{-1em} \arctan(\tan\la\,\cob) \sin\la + [\pi-\arctan(\cot\la\,\cob)] \cos\la \:\frac{\dla}{2\pi} \\ +& = \frac{-e \sin\la_\peri}{\pi/2} \Big[ +\cot\eps \artanh(\sin\la\,\sob) - \cos\la \arctan(\tan\la\,\cob) \\ +& \hspace{1.75cm} + \cot\eps \artanh(\cos\la\,\sob) - \sin\la \arctan(\cot\la\,\cob) + \pi \sin\la \Big]_0^{\pi/2} \\ +& = \frac{-e \sin\la_\peri}{\pi/2} \Big[ \cot\eps [\artanh(\sob) - \artanh(0)] - \{ 0 \arctan(\infty) - \arctan(0) \} \\ +& \hspace{2cm} + \cot\eps [\artanh(0) - \artanh(\sob)] - \{ \arctan(0) - 0 \arctan(\infty) \} + \pi \Big] \\ +& = -2e \sin\la_\peri. +\end{split} +\eeq +Now, by (\ref{eq:mEOT-gen}), +\beq +\begin{split} +\langle EOT & \rangle_{u_{\fpoa'}+Y/2} \\ +& = \MA(u_{\fpoa'}+Y/2) + \la_\peri - \langle \al_\sun \rangle_{u_{\fpoa'}+Y/2} \\ +& = \MA(u_{\fpoa'}) + \pi + \la_\peri + 2e \sin\la_\peri \\ +& = E(u_{\fpoa'}) - e \sin E(u_{\fpoa'}) + \pi + \la_\peri + 2e \sin\la_\peri \\ +& = 2\arctan\left[ \sqrt{\frac{1-e}{1+e}}\tan\left(\frac{\nu(u_{\fpoa'})}{2}\right) \right] - \frac{e\sqrt{1-e^2}\sin\nu(u_{\fpoa'})}{1 + e\cos\nu(u_{\fpoa'})} + \pi + \la_\peri + 2e \sin\la_\peri \\ +& = -2\arctan\left[ \sqrt{\frac{1-e}{1+e}}\tan\left(\frac{\la_\peri + \pi}{2}\right) \right] + \frac{e\sqrt{1-e^2}\sin(\la_\peri + \pi)}{1 + e\cos(\la_\peri + \pi)} + \pi + \la_\peri + 2e \sin\la_\peri \\ +& = -2\arctan\left[ \sqrt{\frac{1-e}{1+e}}\tan\left(\frac{\la_\peri + \pi}{2}\right) \right] - \frac{e\sqrt{1-e^2}\sin\la_\peri}{1 - e\cos\la_\peri} + \pi + \la_\peri + 2e \sin\la_\peri, +\end{split} +\eeq +since $\MA = E - e\sin E$ and since the eccentric anomaly $E$ obeys the following relations from the two-body solution, +\beq +\sin E = \frac{\sqrt{1-e^2}\sin\nu}{1 + e\cos\nu}, \quad +\tan(E/2) = \sqrt{\frac{1-e}{1+e}}\tan(\nu/2), +\eeq +with $\nu = \la - \la_\peri$, and since $\nu(u_{\fpoa'}) = \la(u_{\fpoa'}) - \la_\peri = -(\la_\peri + \pi)$. +Hence, to our first order in $e$ approximation, +\beq +\begin{split} +\langle EOT & \rangle_{u_{\fpoa'}+Y/2} + \approx -2\arctan\left[ (1-e)\tan\left(\frac{\la_\peri + \pi}{2} \right) \right] - e\sin\la_\peri + \pi + \la_\peri + 2e \sin\la_\peri \\ +& \approx -2 \arctan\left[ \tan\left(\frac{\la_\peri + \pi}{2} \right) \right] + \frac{2e\tan\left(\frac{\la_\peri + \pi}{2} \right)}{1+\tan^2\left(\frac{\la_\peri + \pi}{2} \right)} + \pi + \la_\peri + e \sin\la_\peri \\ +& = e\sin2\left(\frac{\la_\peri + \pi}{2} \right) + e \sin\la_\peri = e [ \sin(\la_\peri + \pi) + \sin\la_\peri ] = 0, +\end{split} +\eeq +as required. +%\[ E = 2\arctan\left( \sqrt{\frac{1-e}{1+e}}\tan(\nu/2) \right) \] +We could proceed to higher order in $e$ by this method, but first we will try a slightly different approach, +using integration by parts, which will be turn out to be easier \ldots + +\subsection{General case using integration by parts} + +Alternatively, we can integrate by parts: +\beq +\begin{split} +\langle\al_\sun\rangle_{u_{\fpoa'}+Y/2} +& = \int_{M(u_{\fpoa'})}^{M(u_{\fpoa'})+2\pi} \hspace{-1em} \al_\sun \frac{\dM}{2\pi} + = \frac{1}{2\pi}\! \left( \left[\al_\sun M \right]_{u_{\fpoa'}}^{u_{\fpoa'}+Y} - \int_{-\pi}^{+\pi} M \,\text{d}\al_\sun \right) \\ +& = M(u_{\fpoa'})+\pi - \frac{1}{2\pi} \int_{-\pi}^{+\pi} M \,\frac{\text{d}\al_\sun}{\dla} \,\dla \\ +& = M(u_{\fpoa'})+\pi - \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{(E - e \sin E) \,\cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps}, +\end{split} +\eeq +where (again) $M \equiv \MA = E - e \sin E$, and since $\al_\sun(u_{\fpoa'}) = \pm \pi$ and +\beq +\frac{\partial}{\partial x} \atan2(y,x) = \frac{-y}{x^2 + y^2} \quad\text{and}\quad +\frac{\partial}{\partial y} \atan2(y,x) = \frac{x}{x^2 + y^2}, +\eeq +and so +\beq +\frac{\dee \al_\sun}{\dla} += \frac{\dee}{\dla} \atan2\,(\sin\la\,\cob, \cos\la) = \ldots +% = \frac{-\sin\la\,\cob \cdot -\sin\la + \cos\la \cdot \cos\la\,\cob} {\cos^2\!\la + \sin^2\!\la \,\cos^2\eps} \\ +% = \frac{\cob} {\cos^2\!\la + \sin^2\!\la \,\cos^2\eps} += .\frac{\cob} {1 - \sin^2\!\la \,\sin^2\eps} +\label{eq;dasdla} +\eeq +Hence, before making any approximation in the order of $e$, we have +\beq +\begin{split} +\langle EOT & \rangle_{u_{\fpoa'}+Y/2} = \MA(u_{\fpoa'}) + \pi + \la_\peri - \langle \al_\sun \rangle_{u_{\fpoa'}+Y/2} \\ +& = \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{(E - e \sin E) \,\cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} +\frac{\left[2\arctan\left( \sqrt{\frac{1-e}{1+e}}\tan\left(\frac{\nu}{2}\right) \right) - \frac{e\sqrt{1-e^2}\sin\nu}{1 + e\cos\nu} \right] \cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps}, +\end{split} +\eeq +with $\nu = \la - \la_\peri$. Clearly this method avoids explicit calculation of $ \MA(u_{\fpoa'})$. + +\subsubsection{First order in $e$} + +To {\em first\/} order in $e$: +\beq +\begin{split} +\langle EOT & \rangle_{u_{\fpoa'}+Y/2} \\ +& \approx \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[2\arctan\left( (1-e)\tan\left(\frac{\la - \la_\peri}{2}\right) \right) - e\sin(\la - \la_\peri) \right] \cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& \approx \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[\la - \la_\peri - \frac{2e \tan\left(\frac{\la - \la_\peri}{2}\right)}{1 + \tan^2\left(\frac{\la - \la_\peri}{2}\right)} + - e\sin(\la - \la_\peri) \right] \cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[\la - \la_\peri - 2e\sin(\la - \la_\peri) \right] \cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[\la - \la_\peri - 2e(\sin\la\cos\la_\peri - \cos\la\sin\la_\peri) \right] \cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \la_\peri - \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[\la_\peri - 2e\sin\la_\peri\,\cos\la \right] \cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps}, +\end{split} +\eeq +after removing odd functions of $\la$ in the last line. By (\ref{eq;dasdla}) we can simplify this to +\beq +\begin{split} +\langle EOT & \rangle_{u_{\fpoa'}+Y/2} += \la_\peri - \frac{\la_\peri}{2\pi} \int_{-\pi}^{+\pi} \dee \al_\sun + \frac{2e\sin\la_\peri}{2\pi} \int_{-\pi}^{+\pi} \frac{\cos\la \,\cob\; \dla} {1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \frac{2e\sin\la_\peri}{2\pi} \int_0^0 \frac{\cob\; \dee Y} {1 - Y^2 \,\sin^2\eps} = 0, \quad \text{where}\;Y \equiv \sin\la, +\end{split} +\eeq +so again we have our required result to first order in $e$. + +\subsubsection{Higher orders in $e$} + +At this point we have not been able to go to higher orders in $e$. +Can cannot say whether these orders will yield zero contributions to mean $EOT$ or not. +Here's where I got so far, which perhaps suggest that the mean $EOT$ is only zero to first order \ldots + +The following binomial series converge absolutely since $e \ll 1$: +\beq +(1-e^2)^{1/2} = 1 + A, \quad A \equiv \sum_{k=1}^{\infty} {1/2 \choose k} (-1)^k e^{2k} \sim O(e^2), +\eeq + +\beq +(1-e^2)^{-1/2} = 1 + B, \quad B \equiv \sum_{k=1}^{\infty} {-1/2 \choose k} (-1)^k e^{2k} \sim O(e^2), +\eeq +and +\beq +(1 + e\cos\nu)^{-1} = 1 + C, \quad C \equiv \sum_{k=1}^{\infty} {-1\choose k} e^k\cos^k\nu \sim O(e). +\eeq +Then +\beq +\sqrt{\frac{1-e}{1+e}} = (1-e) (1 + B) = 1 - e + D, \quad D \equiv (1-e) B \sim O(e^2), +\eeq +and, +\beq +\frac{\sqrt{1-e^2}}{1 + e\cos\nu} = (1 + A) (1 + C) = 1 + C + A + AC. +\eeq +So, to general order in $e$, +\beq +\begin{split} +Q &\equiv 2\arctan\left( \sqrt{\frac{1-e}{1+e}}\tan\left(\frac{\nu}{2}\right) \right) - \frac{e\sqrt{1-e^2}\sin\nu}{1 + e\cos\nu} \\ +& = 2\arctan\left( \tan\left(\frac{\nu}{2}\right) + (D - e) \tan\left(\frac{\nu}{2}\right) \right) - e(1 + C + A + AC)\sin\nu = \ldots \\ +& = \nu + (D - 2e - eA) \sin\nu - e(1 + A)C\sin\nu \\ +& \quad\quad + 2 \sum_{n=2}^{\infty} \arctan^{(n)} \left( \tan\left(\frac{\nu}{2}\right) \right) \frac{(D - e)^n}{n!} \tan^n \left(\frac{\nu}{2}\right). +\end{split} +\eeq +Hence, +\beq +\begin{split} +\langle & EOT \rangle_{u_{\fpoa'}+Y/2} = \la_\peri + \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{Q \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} = \ldots \\ +& = \frac{1}{2\pi} \sum_{n=2}^{\infty} \frac{(D - e)^n}{n!} \int_{-\pi}^{+\pi} \frac{2\arctan^{(n)} \left( \tan\left(\frac{\la-\la_\peri}{2}\right) \right) \tan^n \left(\frac{\la-\la_\peri}{2}\right) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& \quad\quad - \frac{e(1 + A)}{2\pi} \sum_{k=1}^{\infty} {-1\choose k} e^k \int_{-\pi}^{+\pi} \frac{ \cos^k(\la-\la_\peri) \sin(\la-\la_\peri) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps}. +\label{eq:mEOT-high} +\end{split} +\eeq +First look at the $\cos^k(\la-\la_\peri) \sin(\la-\la_\peri)$ terms: +\beq +\cos^k(\la-\la_\peri) \sin(\la-\la_\peri) = (C_1C_{1p} + S_1S_{1p})^k (S_1C_{1p} - C_1S_{1p}). +\eeq +where $C_n \equiv \cos(n\la)$, $S_n \equiv \sin(n\la)$ and the $p$ subscripts are for the $\la_\peri$ versions. +For $k=1$, +\beq +(C_1C_{1p} + S_1S_{1p})(S_1C_{1p} - C_1S_{1p}). +%S_1C_1(C_{1p}^2 - S_{1p}^2) - (C_1^2 - S_1^2) S_{1p} C_{1p} += (S_2 C_{2p} - C_2 S_{2p}) / 2. +\eeq +The first term is odd in $\la$ and will integrate to zero, but the second term is even and will not be zero! So perhaps our result +is only good to first order in $e$? The order $e^2$ component from (\ref{eq:mEOT-high}) for these terms is then: +\beq +\begin{split} +\frac{e^2}{2\pi} & \int_{-\pi}^{+\pi} \frac{ \cos(\la-\la_\peri) \sin(\la-\la_\peri) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& -\frac{e^2\sin(2\la_\peri)}{4\pi} \int_{-\pi}^{+\pi} \frac{ \cos(2\la) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& \quad = \frac{e^2\sin(2\la_\peri)}{8\pi\sin^2\eps} \Big[ (\cos(2\eps) + 3) \arctan(\cob \tan\la) - 4 \la\,\cob \Big]_{-\pi}^{+\pi} \\ +& \quad = -e^2 \cot\eps \csc\eps \sin(2\la_\peri). +\label{eq:mEOT-2nd-a} +\end{split} +\eeq +Likewise, the derivatives of $\arctan$ term of (\ref{eq:mEOT-high}) for order $e^2$ is: +\beq +\begin{split} + \frac{e^2}{2} & \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{2\arctan^{(2)} \left( \tan\left(\frac{\la-\la_\peri}{2}\right) \right) \tan^2 \left(\frac{\la-\la_\peri}{2}\right) \cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +% & = -\frac{e^2}{2} \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\left[ \frac{2\tan\left(\frac{\la-\la_\peri}{2}\right)}{1+\tan^2\left(\frac{\la-\la_\peri}{2}\right)} \right]^2 \tan \left(\frac{\la-\la_\peri}{2}\right) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& = -\frac{e^2}{2} \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\sin^2(\la-\la_\peri) \tan \left(\frac{\la-\la_\peri}{2}\right) \cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& = -\frac{e^2}{2} \frac{1}{2\pi} \int_{-\pi}^{+\pi} \frac{\sin(\la-\la_\peri) [1 - \cos(\la-\la_\peri)] \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps} \\ +& = \frac{1}{2} \frac{e^2}{2\pi} \int_{-\pi}^{+\pi} \frac{\sin(\la-\la_\peri) \cos(\la-\la_\peri) \,\cob\; \dla}{1 - \sin^2\!\la \,\sin^2\eps}, +\label{eq:mEOT-2nd-b} +\end{split} +\eeq +which is exactly half of (\ref{eq:mEOT-2nd-a}). So, we conclude that to second order in $e$, +\beq +\langle EOT \rangle_{u_{\fpoa'}+Y/2} = -\tfrac{3}{2} e^2 \cot\eps \csc\eps \sin(2\la_\peri) +\eeq +We will not pursue any higher order terms. For typical J2000 values $e \approx 0.0167$, $\eps \approx 23.44^\circ$, +and $\la_\peri \approx 102.95^\circ - 180^\circ = -77.05^\circ$, +the above formula gives +\beq +\langle EOT \rangle_{u_{\fpoa'}+Y/2} +%\approx -1.5\, (0.0167)^2 \times5.798 \times -0.4368 +\approx 0.00106 \,\text{rad} \approx 15\,\text{sec}. +\eeq + +Thus, we conclude that our simple choice of $u_R$ in (\ref{eq:uR-choice}) leads to zero mean $EOT$ only to first order in $e$. + +\end{document} + + + diff --git a/MAPL_Base/overload.macro b/MAPL_Base/overload.macro index 676c618493ea..d3631419848f 100755 --- a/MAPL_Base/overload.macro +++ b/MAPL_Base/overload.macro @@ -1,4 +1,3 @@ -! $Id$ #ifdef TYPE_ #undef TYPE_ diff --git a/MAPL_Base/read_parallel.H b/MAPL_Base/read_parallel.H index 51353b3ea71b..d0350df23b3a 100644 --- a/MAPL_Base/read_parallel.H +++ b/MAPL_Base/read_parallel.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -32,9 +31,9 @@ subroutine SUB_ ( layout, DATA, UNIT, FORMAT, arrdes, RC) integer :: USABLE_UNIT integer :: IOSTAT integer :: status - character(len=ESMF_MAXSTR) :: IAM='READ_PARALLEL' #if (RANK_ == 1 && VARTYPE_ == 4) integer :: nretries + character(len=ESMF_MAXSTR) :: IAM='READ_PARALLEL' #endif if(present(arrdes)) then diff --git a/MAPL_Base/recv.H b/MAPL_Base/recv.H index 0a0144792685..74af62acb51b 100644 --- a/MAPL_Base/recv.H +++ b/MAPL_Base/recv.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/scatter.H b/MAPL_Base/scatter.H index 77aeb1d29537..6f8a10970eb0 100644 --- a/MAPL_Base/scatter.H +++ b/MAPL_Base/scatter.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/send.H b/MAPL_Base/send.H index ccd733dd0ad1..cd5c3ccc7cc7 100644 --- a/MAPL_Base/send.H +++ b/MAPL_Base/send.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/sendrecv.H b/MAPL_Base/sendrecv.H index 1402c11291a8..5a325dd9a2fd 100644 --- a/MAPL_Base/sendrecv.H +++ b/MAPL_Base/sendrecv.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ diff --git a/MAPL_Base/sun.H b/MAPL_Base/sun.H index f64867dfc30c..390c0bedf4d2 100644 --- a/MAPL_Base/sun.H +++ b/MAPL_Base/sun.H @@ -1,4 +1,3 @@ -! $Id$ type(MAPL_SunOrbit), intent(IN ) :: ORBIT @@ -25,7 +24,7 @@ integer :: IDAY, IDAYP1, TIME_ integer :: NT - real :: FAC, ZS, ZC, ANG, AA, DD + real :: FAC, ZS, ZC, ANG, AA, DD, ET real*8 :: SECS integer :: YEAR @@ -35,17 +34,26 @@ type (ESMF_Time) :: CURRENTTIME type (ESMF_Clock) :: MYCLOCK type (ESMF_TimeInterval) :: ts - real, dimension THE_SIZE :: ZTT, SLT, Y, ZTB, ZTD, NCC + real, dimension THE_SIZE :: ZTT, SLT, Y, ZTB, ZTD, NCC + + real(ESMF_KIND_R8) :: days + real :: ECC, OBQ, LAMBDAP + real :: OMECC, OPECC, OMSQECC, EAFAC + real :: MA, EA, dE, TA, LAMBDA, RT, RM + integer :: nits ! Begin + _ASSERT(MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') + + ! which time mode? if (present(TIME)) then TIME_ = TIME else TIME_ = 0 endif - + ! which current time? if (present(currTime)) then CURRENTTIME = CURRTIME else @@ -57,34 +65,48 @@ _VERIFY(STATUS) end if + ! fixed sun option if (ORBIT%FIX_SUN) then - call WRITE_PARALLEL('--- WARNING --- sun.H --- Doubly Periodic Using Daily Mean Solar Insolation') - TIME_=MAPL_SunDailyMean + call WRITE_PARALLEL('--- WARNING --- sun.H --- Doubly Periodic Using Daily Mean Solar Insolation') + TIME_=MAPL_SunDailyMean end if + ! analytic two-body currently only works with TIME_=0 currently + _ASSERT(.NOT.(ORBIT%ANAL2B.AND.TIME_/=0),'analytic two-body orbit currently requires TIME_=0') + MEAN_OR_INST: if(.not.present(INTV) .or. TIME_==MAPL_SunDailyMean & .or. TIME_==MAPL_SunAnnualMean) then call ESMF_TimeGet(CURRENTTIME, YY=YEAR, S=SEC_OF_DAY, & - dayOfYear=DAY_OF_YEAR, RC=STATUS) + dayOfYear=DAY_OF_YEAR, RC=STATUS) _VERIFY(STATUS) - if (ORBIT%FIX_SUN) then - TIME_=10 - YEAR=2005 - SEC_OF_DAY=86400/2 - DAY_OF_YEAR=31*7 - end if + if (.NOT. ORBIT%ANAL2B) then + + if (ORBIT%FIX_SUN) then + TIME_=10 + YEAR=2005 + SEC_OF_DAY=86400/2 + DAY_OF_YEAR=31*7 + end if + + YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) + IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR - YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) - IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR + if(present(DIST)) DIST = ORBIT%PP(IDAY) - if(present(DIST)) DIST = ORBIT%PP(IDAY) + endif select case (TIME_) case(MAPL_SunDailyMean) + ! pmn: EOT will just displace sunlit period wrt mean noon, + ! but the daily mean values will not change + + _ASSERT(.FALSE.,'pmn: MAPL_SunDailyMean probably in error!') + _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') + SLR = sin(LATS)*ORBIT%ZS(IDAY) ZTH = cos(LATS)*ORBIT%ZC(IDAY) Y = max(-1.0,-SLR/ZTH) @@ -92,7 +114,22 @@ where (Y < 1.0) Y = ACOS(Y) SLR = (4.0*ORBIT%PP(IDAY)/MAPL_PI) * (Y *SLR + SIN(Y)*ZTH) + ! pmn: I get this without factor of 4.0 ZTH = SLR*MAPL_PI / (4.0*Y) + ! pmn: If remove factor of 4 above, remove it here too. + ! pmn: This is also wrong because includes the ORBIT%PP(IDAY) factor + + ! pmn: I think these lines should read: + ! SLR = Y * SLR + SIN(Y) * ZTH + ! ZTH = SLR / Y + ! SLR = ORBIT%PP(IDAY) * SLR / MAPL_PI + ! On the assumption that ZTH is meant to be the linear average + ! of cos(sza) over the sunlit part of the day, or what we call ZTHD + ! This routine should also produce an insolation-weighted mean ZTH. + ! After end select, all these different ZTHs are set to ZTH, since this + ! branch is the instantaneous branch, which is clearly not appropriate + ! for a daily or annual mean. + elsewhere SLR = 0.0 ZTH = 0.0 @@ -100,6 +137,15 @@ case(MAPL_SunAnnualMean) + !pmn: consistent with above (and erroneous) SunDailyMean, + ! but unlike MAPL sun_uc.F90 comment: + ! "annual-mean insolation for the year on the clock" + ! its a mean over the whole currently fixed 4-year cycle. + + ! see above + _ASSERT(.FALSE.,'pmn: MAPL_SunAnnualMean probably in error!') + _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') + SLR = 0.0 ZTH = 0.0 @@ -130,31 +176,125 @@ MAPL_SunVernalEquinox , & MAPL_SunSummerSolstice ) + ! Greenwich MEAN solar hour angle OFFSET by PI + ! (since FAC is zero at mignight) FAC = real(SEC_OF_DAY)/86400. ANG = 2.0*MAPL_PI*FAC - if(TIME_==0) then - IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 + if (ORBIT%ANAL2B) then - ZS = ORBIT%ZS(IDAYP1)*FAC + ORBIT%ZS(IDAY)*(1.-FAC) - ZC = ORBIT%ZC(IDAYP1)*FAC + ORBIT%ZC(IDAY)*(1.-FAC) - AA = ORBIT%PP(IDAYP1)*FAC + ORBIT%PP(IDAY)*(1.-FAC) - else - call GETIDAY(IDAY,TIME_,ORBIT,RC=STATUS) + ! include time variation in orbit from reference time + call ESMF_TimeIntervalGet( & + CURRENTTIME - ORBIT%ORB2B_TIME_REF, & + d_r8=days, rc=STATUS) _VERIFY(STATUS) + 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( & + CURRENTTIME - ORBIT%ORB2B_TIME_PERI, & + d_r8=days, rc=STATUS) + _VERIFY(STATUS) + ! mean anomaly + MA = ORBIT%ORB2B_OMG0 * days + ! eccentric anomaly + call invert_Keplers_Newton(MA,ECC,EA,dE,nits) + ! true anomaly + TA = calcTAfromEA(EA,EAFAC) + ! inverse distance to sun squared + AA = 1. / calcRadfromTA(TA,ECC,OMSQECC) ** 2 + ! celestial longitude + LAMBDA = TA + LAMBDAP + ! sin and cos of solar declination + ZS = sin(LAMBDA) * sin(OBQ) + ZC = sqrt(1. - ZS**2) + if (ORBIT%EOT) then + ! 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) + end if + + else + + if(TIME_==0) then + IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 + + ZS = ORBIT%ZS(IDAYP1)*FAC + ORBIT%ZS(IDAY)*(1.-FAC) + ZC = ORBIT%ZC(IDAYP1)*FAC + ORBIT%ZC(IDAY)*(1.-FAC) + AA = ORBIT%PP(IDAYP1)*FAC + ORBIT%PP(IDAY)*(1.-FAC) + if (ORBIT%EOT) & + ET = ORBIT%ET(IDAYP1)*FAC + ORBIT%ET(IDAY)*(1.-FAC) + else + call GETIDAY(IDAY,TIME_,ORBIT,RC=STATUS) + _VERIFY(STATUS) + + ZS = ORBIT%ZS(IDAY) + ZC = ORBIT%ZC(IDAY) + AA = ORBIT%PP(IDAY) + if (ORBIT%EOT) ET = ORBIT%ET(IDAY) + endif - ZS = ORBIT%ZS(IDAY) - ZC = ORBIT%ZC(IDAY) - AA = ORBIT%PP(IDAY) endif - ZTH = ZS*SIN(LATS) + ZC*COS(LATS) & - * (sin(ANG)*SIN(LONS) - cos(ANG)*COS(LONS)) + ! apply equation of time correction? + if (ORBIT%EOT) then + + ! the real (zero at noon) Greenwich MEAN solar hour angle + ANG = ANG + MAPL_PI + + ! Greenwich TRUE solar hour angle + ANG = ANG + ET + + ! LOCAL solar zenith angle + ZTH = ZS*SIN(LATS) + ZC*COS(LATS)*COS(ANG+LONS) + + else + + ! the historical GEOS-5 calculation based on mean solar time, + ! i.e., lacking the required equation of time correction + + ! pmn: this branch can eventually go if EOT becomes default + ! pmn: the sin*sin-cos*cos is less clear and probably less + ! efficient than the EOT branch anyway + + ! solar zenith angle (based on MEAN solar time) + ZTH = ZS*SIN(LATS) + & + ZC*COS(LATS) * (sin(ANG)*SIN(LONS) - cos(ANG)*COS(LONS)) + + end if + + ! enforce zero insolation for sun below horizon ZTH = max(ZTH, 0.0) + + ! normalized downward solar flux at TOA SLR = ZTH*AA if(present(DIST)) DIST = AA + ! ---%--- + +! pmn: Andrea Molod said the following fixed cases are for single column tests, +! which are run at the same start date near or at the equinox. Technic- +! ally, the value of DIST should also be set consistent with these cases, +! since RRTMG uses SC and DIST (not SLR) during the solar REFRESH phase. +! But since the single column test runs always use the same cap_restart +! and so get the same set of default DIST values from above the current +! select statement, at least we are using a CONSISTENT wrong DIST values! +! In fact, the RRTMG REFRESH uses the DIST to multiply the solar input +! at TOA, which is then divided through by again at the end of REFRESH +! to get the required NORMALIZED fluxes. So this is probably only a small +! non-linear effect. In the solar UPDATE_EXPORT() at the heartbeat the +! normalized fluxes are always re-multiplied by SLR, and so the SLR +! values below will be used directly (without reference to DIST.) + case(10) SLR = 0.3278 ZTH = 0.6087247 @@ -208,7 +348,8 @@ if(present(DIST)) DIST = 0.0 call MAPL_SunGetInsolation( LONS, LATS, ORBIT, ZTT, SLT, & - CLOCK=MYCLOCK, TIME=TIME, DIST=DD, RC=STATUS) + CLOCK=MYCLOCK, TIME=TIME, DIST=DD, & + RC=STATUS) _VERIFY(STATUS) if(present(ZTH1)) ZTH1 = max(ZTT,0.0) @@ -231,7 +372,8 @@ _VERIFY(STATUS) call MAPL_SunGetInsolation( LONS, LATS, ORBIT, ZTT, SLT, & - CLOCK=MYCLOCK, TIME=TIME, ZTHB=ZTB, ZTHD=ZTD, DIST=DD, RC=STATUS) + CLOCK=MYCLOCK, TIME=TIME, ZTHB=ZTB, ZTHD=ZTD, DIST=DD, & + RC=STATUS) _VERIFY(STATUS) SLR = SLR + SLT*0.5 diff --git a/MAPL_Base/tests/CMakeLists.txt b/MAPL_Base/tests/CMakeLists.txt index 800b6eeb2e73..617b855ef4f8 100644 --- a/MAPL_Base/tests/CMakeLists.txt +++ b/MAPL_Base/tests/CMakeLists.txt @@ -17,17 +17,27 @@ set (TEST_SRCS # SRCS are mostly mocks to facilitate tests set (SRCS - MAPL_Initialize.F90 MockGridFactory.F90 MockRegridder.F90 ) +# This file needs to be in a library because CMake cannot detect the +# dependency of the pFUnit driver on it. This is due to the use of +# preprocesor in the driver for specifying the include file. +add_library (base_extras + MAPL_Initialize.F90 + ) +target_link_libraries (base_extras PUBLIC ${ESMF_LIBRARIES} MAPL_Base MAPL_pFUnit) +target_include_directories (base_extras PUBLIC ${INC_ESMF}) +target_include_directories (base_extras PUBLIC ${INC_NETCDF}) + + add_pfunit_ctest(MAPL_Base_tests TEST_SOURCES ${TEST_SRCS} OTHER_SOURCES ${SRCS} - LINK_LIBRARIES MAPL_Base GMAO_pFIO MAPL_pFUnit + LINK_LIBRARIES MAPL_Base GMAO_pFIO base_extras MAPL_pFUnit EXTRA_INITIALIZE Initialize - EXTRA_USE MAPL_pFUNIT_Initialize + EXTRA_USE MAPL_pFUnit_Initialize MAX_PES 8 ) diff --git a/MAPL_Base/tests/MAPL_Initialize.F90 b/MAPL_Base/tests/MAPL_Initialize.F90 index d201a6250c1d..6f2f9d231b0f 100644 --- a/MAPL_Base/tests/MAPL_Initialize.F90 +++ b/MAPL_Base/tests/MAPL_Initialize.F90 @@ -1,4 +1,4 @@ -module MAPL_pFUNIT_Initialize +module MAPL_pFUnit_Initialize contains subroutine Initialize() use ESMF @@ -9,4 +9,4 @@ subroutine Initialize() call MAPL_set_throw_method(throw) end subroutine Initialize -end module +end module MAPL_pFUnit_Initialize diff --git a/MAPL_Base/tests/MockGridFactory.F90 b/MAPL_Base/tests/MockGridFactory.F90 index 1023ed2481fb..f10a092f3575 100644 --- a/MAPL_Base/tests/MockGridFactory.F90 +++ b/MAPL_Base/tests/MockGridFactory.F90 @@ -30,6 +30,9 @@ module MockGridFactoryMod procedure :: append_metadata procedure :: append_variable_metadata + procedure :: generate_file_bounds + procedure :: generate_file_reference2D + procedure :: generate_file_reference3D end type MockGridFactory interface MockGridFactory @@ -155,6 +158,10 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, rc) type (FileMetadata), target, intent(in) :: file_metadata class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(file_metadata) + _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(rc) end subroutine initialize_from_file_metadata @@ -162,7 +169,8 @@ subroutine append_metadata(this, metadata) class (MockGridFactory), intent(inout) :: this type (FileMetadata), intent(inout) :: metadata - type (Variable) :: v + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(metadata) !!$ ! Horizontal grid dimensions !!$ call metadata%add_dimension('lon', this%im_world) @@ -173,6 +181,7 @@ function get_grid_vars(this) result(vars) class (MockGridFactory), intent(inout) :: this character(len=:), allocatable :: vars + _UNUSED_DUMMY(this) vars = 'lon,lat, mock' @@ -181,7 +190,45 @@ end function get_grid_vars subroutine append_variable_metadata(this,var) class (MockGridFactory), intent(inout) :: this type(Variable), intent(inout) :: var + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(var) end subroutine append_variable_metadata + subroutine generate_file_bounds(this,grid,local_start,global_start,global_count,rc) + use MAPL_BaseMod + use ESMF + class(MockGridFactory), intent(inout) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, allocatable, intent(inout) :: local_start(:) + integer, allocatable, intent(inout) :: global_start(:) + integer, allocatable, intent(inout) :: global_count(:) + integer, optional, intent(out) :: rc + + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(grid) + _UNUSED_DUMMY(local_start) + _UNUSED_DUMMY(global_start) + _UNUSED_DUMMY(global_count) + _UNUSED_DUMMY(rc) + + end subroutine generate_file_bounds + + function generate_file_reference2D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(MockGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference2D + + function generate_file_reference3D(this,fpointer) result(ref) + use pFIO + type(ArrayReference) :: ref + class(MockGridFactory), intent(inout) :: this + real, pointer, intent(in) :: fpointer(:,:,:) + _UNUSED_DUMMY(this) + ref = ArrayReference(fpointer) + end function generate_file_reference3D end module MockGridFactoryMod diff --git a/MAPL_Base/tests/Test_LatLon_Corners.pf b/MAPL_Base/tests/Test_LatLon_Corners.pf index b6629795f24e..33313e666d7a 100644 --- a/MAPL_Base/tests/Test_LatLon_Corners.pf +++ b/MAPL_Base/tests/Test_LatLon_Corners.pf @@ -1,3 +1,4 @@ +#include "unused_dummy.H" module Test_LatLon_Corners use pfunit use ESMF_TestCase_mod @@ -62,6 +63,7 @@ contains type (Test_LatLonCorners) :: aTest class (GridCase), intent(in) :: testParameter + _UNUSED_DUMMY(testParameter) !$$ allocate(aTest%testParameter, source=testParameter) select type (p => aTest%testParameter) class is (GridCase) diff --git a/MAPL_Base/write_parallel.H b/MAPL_Base/write_parallel.H index 2f7ae26fd2fb..34522e856f2a 100644 --- a/MAPL_Base/write_parallel.H +++ b/MAPL_Base/write_parallel.H @@ -1,4 +1,3 @@ -! $Id$ #ifdef NAME_ #undef NAME_ @@ -27,7 +26,6 @@ subroutine SUB_ ( data, UNIT, ARRDES, format, RC) integer , intent( out), optional :: RC character(len=ESMF_MAXSTR) :: FORMATTED - character(len=ESMF_MAXSTR) :: IAM='WRITE_PARALLEL' integer :: recl, status if(present(arrdes)) then diff --git a/MAPL_Profiler/AbstractColumn.F90 b/MAPL_Profiler/AbstractColumn.F90 new file mode 100644 index 000000000000..7e872e0aa3fe --- /dev/null +++ b/MAPL_Profiler/AbstractColumn.F90 @@ -0,0 +1,89 @@ +module MAPL_AbstractColumn + use GFTL_UnlimitedVector + use MAPL_AbstractMeterNode + use MAPL_DistributedMeter + implicit none + private + + public :: AbstractColumn + + type, abstract :: AbstractColumn + private + contains + procedure(i_get_rows), deferred :: get_rows + procedure, nopass :: fill_row_real64_stats + procedure, nopass :: fill_row_integer_stats + generic :: fill_row => fill_row_real64_stats, fill_row_integer_stats + end type AbstractColumn + + + abstract interface + + function i_get_rows(this, node) result(rows) + import AbstractColumn + import AbstractMeterNode + import UnlimitedVector + ! Some columns return reals, others return integers + type(UnlimitedVector) :: rows + class(AbstractColumn), intent(in) :: this + class(AbstractMeterNode), target, intent(in) :: node + + end function i_get_rows + + end interface + + +contains + + + ! These probably belong somewhere else. + subroutine fill_row_real64_stats(stats, option, row) + type(DistributedReal64), intent(in) :: stats + character(*), intent(in) :: option + class(*), allocatable, intent(out) :: row + + select case (option) + case ('MAX') + allocate(row, source=stats%max) + case ('MAX_PE') + allocate(row, source=stats%max_pe) + case ('MIN') + allocate(row, source=stats%min) + case ('MIN_PE') + allocate(row, source=stats%min_pe) + case ('MEAN') + allocate(row, source=stats%total / stats%num_pes) + case ('TOTAL') + allocate(row, source=stats%total) + case default + print*,__FILE__,__LINE__,'ERROR: unsupported option '//option + end select + + end subroutine fill_row_real64_stats + + subroutine fill_row_integer_stats(stats, option, row) + type(DistributedInteger), intent(in) :: stats + character(*), intent(in) :: option + class(*), allocatable, intent(out) :: row + + select case (option) + case ('MAX') + allocate(row, source=stats%max) + case ('MAX_PE') + allocate(row, source=stats%max_pe) + case ('MIN') + allocate(row, source=stats%min) + case ('MIN_PE') + allocate(row, source=stats%min_pe) + case ('MEAN') + allocate(row, source=stats%total / stats%num_pes) + case ('TOTAL') + allocate(row, source=stats%total) + case default + print*,__FILE__,__LINE__,'ERROR: unsupported option '//option + end select + + end subroutine fill_row_integer_stats + + +end module MAPL_AbstractColumn diff --git a/MAPL_Profiler/AbstractGauge.F90 b/MAPL_Profiler/AbstractGauge.F90 new file mode 100644 index 000000000000..5792cdffcf48 --- /dev/null +++ b/MAPL_Profiler/AbstractGauge.F90 @@ -0,0 +1,27 @@ +module MAPL_AbstractGauge + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractMeter + implicit none + private + + public :: AbstractGauge + type, abstract :: AbstractGauge + private + contains + procedure(i_get_measurement), deferred :: get_measurement + end type AbstractGauge + + + abstract interface + + function i_get_measurement(this) result(measurement) + import REAL64 + import AbstractGauge + real(kind=REAL64) :: measurement + class (AbstractGauge), intent(inout) :: this + end function i_get_measurement + + end interface + + +end module MAPL_AbstractGauge diff --git a/MAPL_Profiler/AbstractMeter.F90 b/MAPL_Profiler/AbstractMeter.F90 new file mode 100644 index 000000000000..0fc963d5d0ac --- /dev/null +++ b/MAPL_Profiler/AbstractMeter.F90 @@ -0,0 +1,51 @@ +module MAPL_AbstractMeter + use, intrinsic :: iso_fortran_env, only: REAL64 + implicit none + private + + public :: AbstractMeter + type, abstract :: AbstractMeter + private + contains + ! Override in subclasses for different timing mechanisms + procedure(i_action), deferred :: start + procedure(i_action), deferred :: stop + procedure(i_action), deferred :: reset + procedure(i_add_cycle), deferred :: add_cycle + + procedure(i_get), deferred :: get_total + procedure(i_accumulate), deferred :: accumulate + + end type AbstractMeter + + + abstract interface + + subroutine i_action(this) + import AbstractMeter + class (AbstractMeter), intent(inout) :: this + end subroutine i_action + + subroutine i_add_cycle(this, increment) + import AbstractMeter + import REAL64 + class (AbstractMeter), intent(inout) :: this + real(kind=REAL64), intent(in) :: increment + end subroutine i_add_cycle + + function i_get(this) result(val) + import AbstractMeter + import REAL64 + real(kind=REAL64) :: val + class (AbstractMeter), intent(in) :: this + end function i_get + + subroutine i_accumulate(this, lap) + import AbstractMeter + class(AbstractMeter), intent(inout) :: this + class(AbstractMeter), intent(in) :: lap + end subroutine i_accumulate + + end interface + +end module MAPL_AbstractMeter diff --git a/MAPL_Profiler/AbstractMeterFactory.F90 b/MAPL_Profiler/AbstractMeterFactory.F90 new file mode 100644 index 000000000000..425d4b840835 --- /dev/null +++ b/MAPL_Profiler/AbstractMeterFactory.F90 @@ -0,0 +1,23 @@ +module MAPL_AbstractMeterFactory + use MAPL_AbstractMeter + implicit none + private + + public :: AbstractMeterFactory + + type, abstract :: AbstractMeterFactory + contains + procedure(i_make_meter), deferred :: make_meter + end type AbstractMeterFactory + + abstract interface + function i_make_meter(this) result(meter) + import AbstractMeterFactory + import AbstractMeter + class(AbstractMeter), allocatable :: meter + class(AbstractMeterFactory), intent(in) :: this + end function i_make_meter + end interface + +end module MAPL_AbstractMeterFactory + diff --git a/MAPL_Profiler/AbstractMeterNode.F90 b/MAPL_Profiler/AbstractMeterNode.F90 new file mode 100644 index 000000000000..ea96fdfe1683 --- /dev/null +++ b/MAPL_Profiler/AbstractMeterNode.F90 @@ -0,0 +1,167 @@ +module MAPL_AbstractMeterNode + use MAPL_AbstractMeter + implicit none + private + + public :: AbstractMeterNode + public :: AbstractMeterNodeIterator + + ! A node consists of a meter and a name. We need an abstract base + ! class so that we can use gFTL in a relatively painless manner. + type, abstract :: AbstractMeterNode + private + contains + procedure(i_get_meter), deferred :: get_meter + procedure(i_get_name), deferred :: get_name + procedure(i_get_depth), deferred :: get_depth + procedure(i_get_inclusive), deferred :: get_inclusive + procedure(i_get_inclusive), deferred :: get_exclusive + procedure(i_add_child), deferred :: add_child + procedure(i_get_child), deferred :: get_child + procedure(i_has_child), deferred :: has_child + procedure(i_get_num_nodes), deferred :: get_num_children + procedure(i_get_num_nodes), deferred :: get_num_nodes + procedure(i_reset), deferred :: reset + procedure(i_accumulate), deferred :: accumulate + + ! Iterator factory methods + procedure(i_make_iterator), deferred :: begin + procedure(i_make_iterator), deferred :: end + end type AbstractMeterNode + + type, abstract :: AbstractMeterNodeIterator + private + contains + procedure(i_get), deferred :: get + procedure(i_iter_get_meter), deferred :: get_meter + procedure(i_iter_get_name), deferred :: get_name + procedure(i_compare), deferred :: equals + procedure(i_compare), deferred :: not_equals + generic :: operator(==) => equals + generic :: operator(/=) => not_equals + procedure(i_next), deferred :: next + end type AbstractMeterNodeIterator + + + abstract interface + + function i_get_meter(this) result(meter) + import AbstractMeter + import AbstractMeterNode + class(AbstractMeter), pointer :: meter + class(AbstractMeterNode), target, intent(in) :: this + end function i_get_meter + + function i_get_depth(this) result(depth) + import AbstractMeterNode + integer :: depth + class(AbstractMeterNode), intent(in) :: this + end function i_get_depth + + + subroutine i_add_child(this, name, meter) + import AbstractMeterNode + import AbstractMeter + class(AbstractMeterNode), target, intent(inout) :: this + character(*), intent(in) :: name + class (AbstractMeter), intent(in) :: meter + end subroutine i_add_child + + + function i_get_child(this, name) result(children) + import AbstractMeterNode + class(AbstractMeterNode), pointer :: children + class(AbstractMeterNode), target, intent(inout) :: this + character(*), intent(in) :: name + end function i_get_child + + + logical function i_has_child(this, name) + import AbstractMeterNode + class(AbstractMeterNode), pointer :: children + class(AbstractMeterNode), target, intent(in) :: this + character(*), intent(in) :: name + end function i_has_child + + + integer function i_get_num_nodes(this) result(num_nodes) + import AbstractMeterNode + class(AbstractMeterNode), target, intent(in) :: this + end function i_get_num_nodes + + + subroutine i_accumulate(this, other) + import AbstractMeterNode + class(AbstractMeterNode), intent(inout) :: this + class(AbstractMeterNode), target, intent(in) :: other + end subroutine i_accumulate + + + function i_get(this) result(node) + import AbstractMeterNode + import AbstractMeterNodeIterator + class(AbstractMeterNode), pointer :: node + class(AbstractMeterNodeIterator), target, intent(in) :: this + end function i_get + + + function i_iter_get_meter(this) result(t) + import AbstractMeterNode + import AbstractMeterNodeIterator + import AbstractMeter + class(AbstractMeter), pointer :: t + class(AbstractMeterNodeIterator), intent(in) :: this + end function i_iter_get_meter + + + function i_iter_get_name(this) result(name) + import AbstractMeterNode + import AbstractMeterNodeIterator + character(:), pointer :: name + class(AbstractMeterNodeIterator), intent(in) :: this + end function i_iter_get_name + + + function i_make_iterator(this) result(iterator) + import AbstractMeterNode + import AbstractMeterNodeIterator + class(AbstractMeterNodeIterator), allocatable :: iterator + class(AbstractMeterNode), target, intent(in) :: this + end function i_make_iterator + + + logical function i_compare(a, b) + import AbstractMeterNodeIterator + class(AbstractMeterNodeIterator), intent(in) :: a + class(AbstractMeterNodeIterator), intent(in) :: b + end function i_compare + + + subroutine i_next(this) + import AbstractMeterNodeIterator + class(AbstractMeterNodeIterator), intent(inout) :: this + end subroutine i_next + + + function i_get_name(this) result(name) + import AbstractMeterNode + character(:), pointer :: name + class(AbstractMeterNode), target, intent(in) :: this + end function i_get_name + + + function i_get_inclusive(this) result(inclusive) + use, intrinsic :: iso_fortran_env, only: REAL64 + import AbstractMeterNode + real(kind=REAL64) :: inclusive + class(AbstractMeterNode), intent(in) :: this + end function i_get_inclusive + + subroutine i_reset(this) + import AbstractMeterNode + class(AbstractMeterNode), target, intent(inout) :: this + end subroutine i_reset + + end interface + +end module MAPL_AbstractMeterNode diff --git a/MAPL_Profiler/AdvancedMeter.F90 b/MAPL_Profiler/AdvancedMeter.F90 new file mode 100644 index 000000000000..7d4c90398892 --- /dev/null +++ b/MAPL_Profiler/AdvancedMeter.F90 @@ -0,0 +1,292 @@ +#include "unused_dummy.H" + +module MAPL_AdvancedMeter + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractMeter + use MAPL_AbstractGauge + implicit none + private + + public :: AdvancedMeter + + public :: MAPL_METER_IS_VALID + public :: MAPL_METER_START_ACTIVE + public :: MAPL_METER_STOP_INACTIVE + + enum, bind(c) + enumerator :: MAPL_METER_IS_VALID = 0 + enumerator :: MAPL_METER_START_ACTIVE + enumerator :: MAPL_METER_STOP_INACTIVE + end enum + + type, extends(AbstractMeter) :: AdvancedMeter + private + + class(AbstractGauge), allocatable :: gauge + real(kind=REAL64) :: start_value + + real(kind=REAL64) :: total = 0 + logical :: active = .false. + integer :: status = MAPL_METER_IS_VALID + + real(kind=REAL64) :: min_cycle = huge(1._REAL64) + real(kind=REAL64) :: max_cycle = 0. + real(kind=REAL64) :: sum_square_deviation = 0. + + integer :: num_cycles = 0 + + contains + + procedure :: start + procedure :: stop + + procedure :: reset + procedure :: is_active + procedure :: get_status + procedure :: get_overhead + + procedure :: get_total + + procedure :: get_min_cycle + procedure :: get_max_cycle + procedure :: get_mean_cycle + procedure :: get_sum_square_deviation + procedure :: get_standard_deviation + procedure :: get_relative_deviation + procedure :: get_num_cycles + + procedure :: add_cycle + procedure :: accumulate + + + end type AdvancedMeter + + + + interface AdvancedMeter + module procedure :: new_AdvancedMeter + end interface AdvancedMeter + + +contains + + + function new_AdvancedMeter(gauge) result(meter) + type(AdvancedMeter) :: meter + class(AbstractGauge), intent(in) :: gauge + + meter%gauge = gauge + + end function new_AdvancedMeter + + + subroutine start(this) + class(AdvancedMeter), intent(inout) :: this + + if (this%active) then + this%status = MAPL_METER_START_ACTIVE + return + end if + + this%active = .true. + + this%start_value = this%gauge%get_measurement() + + end subroutine start + + + subroutine stop(this) + class(AdvancedMeter), intent(inout) :: this + + real(kind=REAL64) :: increment + + if (.not. this%active) then + this%status = MAPL_METER_STOP_INACTIVE + return + end if + + this%active = .false. + increment = this%gauge%get_measurement() - this%start_value + call this%add_cycle(increment) + + end subroutine stop + + + function get_total(this) result(val) + real(kind=REAL64) :: val + class(AdvancedMeter), intent(in) :: this + + val = this%total + + end function get_total + + + logical function is_active(this) + class(AdvancedMeter), intent(in) :: this + is_active = this%active + end function is_active + + + integer function get_status(this) result(status) + class(AdvancedMeter), intent(in) :: this + status = this%status + end function get_status + + + subroutine add_cycle(this, increment) + class(AdvancedMeter), intent(inout) :: this + real(kind=REAL64), intent(in) :: increment + + real(kind=REAL64) :: old_mean, new_mean + + associate ( n => this%num_cycles, t => increment ) + this%min_cycle = min(this%min_cycle, t) + this%max_cycle = max(this%max_cycle, t) + + old_mean = this%get_mean_cycle() + n = n + 1 + new_mean = old_mean + (t - old_mean) / n ! denominator provably always > 0 (modulo integer overflow) + + this%sum_square_deviation = this%sum_square_deviation + (t - old_mean)*(t - new_mean) + + this%total = this%total + t + + end associate + + + end subroutine add_cycle + + + subroutine reset(this) + class(AdvancedMeter), intent(inout) :: this + + this%total = 0 + this%active = .false. + + this%num_cycles = 0 + this%min_cycle = huge(1._REAL64) + this%max_cycle = 0._REAL64 + this%sum_square_deviation = 0._REAL64 + + end subroutine reset + + + + function get_min_cycle(this) result(min_cycle) + real(kind=REAL64) :: min_cycle + class(AdvancedMeter), intent(in) :: this + + min_cycle = this%min_cycle + + end function get_min_cycle + + + function get_max_cycle(this) result(max_cycle) + real(kind=REAL64) :: max_cycle + class(AdvancedMeter), intent(in) :: this + + max_cycle = this%max_cycle + + end function get_max_cycle + + + function get_mean_cycle(this) result(mean_cycle) + real(kind=REAL64) :: mean_cycle + class(AdvancedMeter), intent(in) :: this + + integer :: n + + n = this%get_num_cycles() + if (n > 0) then + mean_cycle = this%total / n + else + mean_cycle = 0 ! undefined actually + end if + + end function get_mean_cycle + + + function get_sum_square_deviation(this) result(sum_square_deviation) + real(kind=REAL64) :: sum_square_deviation + class(AdvancedMeter), intent(in) :: this + + sum_square_deviation = this%sum_square_deviation + + end function get_sum_square_deviation + + + function get_standard_deviation(this) result(standard_deviation) + real(kind=REAL64) :: standard_deviation + class(AdvancedMeter), intent(in) :: this + + standard_deviation = sqrt(this%sum_square_deviation / this%num_cycles) + + end function get_standard_deviation + + + ! Relative standard deviation (expressed as percentage) + ! R = 100 * standard_deviation / mean + ! https://en.wikipedia.org/wiki/Coefficient_of_variation + function get_relative_deviation(this) result(relative_deviation) + use, intrinsic :: ieee_arithmetic, only: IEEE_POSITIVE_INF, ieee_value + real(kind=REAL64) :: relative_deviation + class(AdvancedMeter), intent(in) :: this + + real(kind=REAL64) :: abs_mean + + abs_mean = abs(this%get_mean_cycle()) + if (abs_mean > 0) then + relative_deviation = 100*(this%get_standard_deviation()/abs_mean) + else + ! Gfortran stops with overflow exception even to do the assignment below. + ! So we default to 0 when there the mean is 0. + relative_deviation = ieee_value(1.0_REAL64, IEEE_POSITIVE_INF) + end if + + end function get_relative_deviation + + + integer function get_num_cycles(this) result(num_cycles) + class(AdvancedMeter), intent(in) :: this + + num_cycles = this%num_cycles + + end function get_num_cycles + + + function get_overhead(this) result(overhead) + real(kind=REAL64) :: overhead + class(AdvancedMeter), intent(in) :: this + + class(AdvancedMeter), allocatable :: t_outer + class(AdvancedMeter), allocatable :: t_inner + + call t_outer%start() + call t_inner%start() + call t_inner%stop() + call t_outer%stop() + + overhead = t_outer%get_total() + + end function get_overhead + + + subroutine accumulate(this, lap) + class(AdvancedMeter), intent(inout) :: this + class(AbstractMeter), intent(in) :: lap + + select type(lap) + class is (AdvancedMeter) + this%min_cycle = min(this%min_cycle, lap%min_cycle) + this%max_cycle = max(this%max_cycle, lap%max_cycle) + + this%total = this%total + lap%total + this%num_cycles = this%num_cycles + lap%num_cycles + this%sum_square_deviation = this%sum_square_deviation + lap%sum_square_deviation + class default + print*,'add error handling here' + end select + + end subroutine accumulate + +end module MAPL_AdvancedMeter diff --git a/MAPL_Profiler/BaseProfiler.F90 b/MAPL_Profiler/BaseProfiler.F90 new file mode 100644 index 000000000000..5976bcd3e02e --- /dev/null +++ b/MAPL_Profiler/BaseProfiler.F90 @@ -0,0 +1,396 @@ +module MAPL_BaseProfiler + use MAPL_AdvancedMeter + use MAPL_AbstractMeter + use MAPL_AbstractMeterNode + use MAPL_MeterNode + use MAPL_MeterNodeStack + implicit none + private + + public :: BaseProfiler + public :: BaseProfilerIterator + + public :: INCORRECTLY_NESTED_METERS + + enum, bind(c) + enumerator :: INCORRECTLY_NESTED_METERS=1 + end enum + + type, abstract :: BaseProfiler + private + type(MeterNode) :: node + type(MeterNodeStack) :: stack + integer :: status = 0 + integer :: comm_world + contains + procedure :: start_name + procedure :: stop_name + procedure :: start_self + procedure :: stop_self + generic :: start => start_name + generic :: start => start_self + generic :: stop => stop_name + generic :: stop => stop_self + generic :: zeit_ci => start_name + generic :: zeit_co => stop_name + procedure :: get_num_meters + procedure :: finalize + + ! Override make_meter() to measure other things. + procedure(i_make_meter), deferred :: make_meter + + procedure :: set_node + procedure :: get_root_node + procedure :: get_status + procedure :: copy_profiler + procedure(copy_profiler), deferred :: copy + generic :: assignment(=) => copy + + procedure :: reset + procedure :: accumulate + + procedure :: begin + procedure :: end + procedure :: get_depth + procedure :: set_comm_world + + end type BaseProfiler + + type :: BaseProfilerIterator + private + class (AbstractMeterNodeIterator), allocatable :: node_iterator + contains + procedure :: get_node + procedure :: get_meter + procedure :: get_name + procedure :: next + procedure :: equals + procedure :: not_equals + generic :: operator(==) => equals + generic :: operator(/=) => not_equals + end type BaseProfilerIterator + + abstract interface + + function i_make_meter(this) result(meter) + import AbstractMeter + import BaseProfiler + class(AbstractMeter), allocatable :: meter + class(BaseProfiler), intent(in) :: this + end function i_make_meter + + end interface + + +contains + + + subroutine start_self(this) + class(BaseProfiler), target, intent(inout) :: this + + class(AbstractMeter), pointer :: t + + call this%stack%push_back(this%node) + + if( .not. this%stack%size() == 1) then + block + use MPI + integer :: rank, ierror + call MPI_Comm_rank(this%comm_world, rank, ierror) + if (rank == 0) then + print*,__FILE__,__LINE__,'nesting start called on self timer' + end if + end block + end if + + t => this%node%get_meter() + call t%start() + + end subroutine start_self + + subroutine start_name(this, name) + class(BaseProfiler), target, intent(inout) :: this + character(*), intent(in) :: name + + class(AbstractMeter), pointer :: t + class(AbstractMeterNode), pointer :: node + class(AbstractMeter), allocatable :: m + + if (this%stack%empty()) then + block + use MPI + integer :: rank, ierror + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror) + if (rank == 0) then + print*,'start name should not be empty: ', __FILE__,__LINE__,name + end if + end block + return + else + node => this%stack%back() + if (.not. node%has_child(name)) then + m = this%make_meter() + call node%add_child(name, m) !this%make_meter()) + end if + endif + + node => node%get_child(name) + call this%stack%push_back(node) + + t => node%get_meter() + call t%start() + + end subroutine start_name + + + subroutine stop_name(this, name) + class(BaseProfiler), intent(inout) :: this + character(*), intent(in) :: name + + class(AbstractMeter), pointer :: t + class(AbstractMeterNode), pointer :: node + + node => this%stack%back() + t => node%get_meter() + if (name /= node%get_name()) then + this%status = INCORRECTLY_NESTED_METERS + block + use MPI + integer :: rank, ierror + call MPI_Comm_rank(this%comm_world, rank, ierror) + if (rank == 0) then + print*,__FILE__,__LINE__,'stop called on non-bottom timer'//name + end if + end block + return + end if + call t%stop() + call this%stack%pop_back() + + end subroutine stop_name + + subroutine stop_self(this) + class(BaseProfiler), intent(inout) :: this + + class(AbstractMeter), pointer :: t + class(AbstractMeterNode), pointer :: node + + if( .not. this%stack%size() == 1) then + block + use MPI + integer :: rank, ierror + call MPI_Comm_rank(this%comm_world, rank, ierror) + if (rank == 0) then + print*,__FILE__,__LINE__,'stop called on self timer' + end if + end block + end if + + node => this%stack%back() + t => node%get_meter() + call t%stop() + call this%stack%pop_back() + + end subroutine stop_self + + + integer function get_num_meters(this) result(num_meters) + class(BaseProfiler), intent(in) :: this + + num_meters = this%node%get_num_nodes() + + end function get_num_meters + + + subroutine finalize(this) + class(BaseProfiler), target, intent(inout) :: this + + class(AbstractMeter), pointer :: t + + call this%stack%pop_back() + t => this%node%get_meter() + call t%stop() + + end subroutine finalize + + subroutine copy_profiler(new, old) + class(BaseProfiler), target, intent(inout) :: new + class(BaseProfiler), target, intent(in) :: old + + class(AbstractMeterNode), pointer :: subnode + class(AbstractMeterNode), pointer :: next_item + type(MeterNodeStackIterator) :: iter + character(:), pointer :: name + + new%node = old%node + new%comm_world = old%comm_world + subnode => new%node + + ! Stack always starts with root node of node + + if (old%stack%empty()) return + + iter = old%stack%begin() + call new%stack%push_back(subnode) + call iter%next() + + do while (iter /= old%stack%end()) + next_item => iter%get() + name => next_item%get_name() + subnode => subnode%get_child(name) + call new%stack%push_back(subnode) + call iter%next() + end do + + end subroutine copy_profiler + + + integer function get_status(this) result(status) + class(BaseProfiler), intent(in) :: this + status = this%status + end function get_status + + + + function get_root_node(this) result(root_node) + class(AbstractMeterNode), pointer :: root_node + class(BaseProfiler), target, intent(in) :: this + + root_node => this%node + + end function get_root_node + + + ! TODO: move most logic to MeterNode + recursive subroutine reset(this) + class(BaseProfiler), target, intent(inout) :: this + class(AbstractMeterNodeIterator), allocatable :: iter + class(AbstractMeterNode), pointer :: node + class(AbstractMeter), pointer :: t + + node => this%get_root_node() + iter = node%begin() + do while (iter /= node%end()) + t => iter%get_meter() + call t%reset() + call iter%next() + end do + + call this%start() + + end subroutine reset + + + recursive subroutine accumulate(a, b) + class(BaseProfiler), target, intent(inout) :: a + class(BaseProfiler), target, intent(in) :: b + + class(AbstractMeterNode), pointer :: node_a, node_b + + node_a => a%stack%back() + node_b => b%get_root_node() + + call node_a%accumulate(node_b) + + end subroutine accumulate + + + function begin(this) result(iterator) + type (BaseProfilerIterator) :: iterator + class (BaseProfiler), target, intent(in) :: this + + iterator%node_iterator = this%node%begin() + end function begin + + function end(this) result(iterator) + type (BaseProfilerIterator) :: iterator + class (BaseProfiler), target, intent(in) :: this + + iterator%node_iterator = this%node%end() + end function end + + + subroutine next(this) + class (BaseProfilerIterator), intent(inout) :: this + call this%node_iterator%next() + end subroutine next + + ! Type cast to concrete class for convenience of client code. + function get_node(this) result(node) + class (MeterNode), pointer :: node + class (BaseProfilerIterator), target, intent(in) :: this + + class (AbstractMeterNode), pointer :: abstract_node + + abstract_node => this%node_iterator%get() + select type (q => abstract_node) + class is (MeterNode) + node => q + class default + print*,'put error handling here' + end select + + end function get_node + + + subroutine set_node(this, node) + class (BaseProfiler), intent(inout) :: this + type (MeterNode), intent(in) :: node + this%node = node + end subroutine set_node + + function get_name(this) result(name) + character(:), pointer :: name + class (BaseProfilerIterator), target, intent(in) :: this + name => this%node_iterator%get_name() + end function get_name + + function get_meter(this) result(meter) + class (AdvancedMeter), pointer :: meter + class (BaseProfilerIterator), target, intent(in) :: this + + class (AbstractMeter), pointer :: abstract_meter + + abstract_meter => this%node_iterator%get_meter() + select type (q => abstract_meter) + class is (AdvancedMeter) + meter => q + class default + print*,'put error handling here' + end select + end function get_meter + + logical function equals(this, other) + class (BaseProfilerIterator), intent(in) :: this + class (BaseProfilerIterator), intent(in) :: other + equals = (this%node_iterator == other%node_iterator) + end function equals + + logical function not_equals(this, other) + class (BaseProfilerIterator), intent(in) :: this + class (BaseProfilerIterator), intent(in) :: other + not_equals = .not. (this == other) + end function not_equals + + integer function get_depth(this) result(depth) + class(BaseProfiler), intent(in) :: this + depth = this%stack%size() + end function get_depth + + subroutine set_comm_world(this, comm_world) + use MPI + class(BaseProfiler), intent(inout) :: this + integer, optional, intent(in) :: comm_world + integer :: status + + if(present(comm_world)) then + call MPI_Comm_dup(comm_world, this%comm_world, status) + else + this%comm_world = MPI_COMM_WORLD + endif + end subroutine set_comm_world + +end module MAPL_BaseProfiler + + + diff --git a/MAPL_Profiler/CMakeLists.txt b/MAPL_Profiler/CMakeLists.txt new file mode 100644 index 000000000000..acd42beb4517 --- /dev/null +++ b/MAPL_Profiler/CMakeLists.txt @@ -0,0 +1,64 @@ +esma_set_this () + +set (srcs + AbstractMeter.F90 + AbstractMeterNode.F90 + AbstractMeterFactory.F90 + MeterNodeVector.F90 + MeterNodeStack.F90 + + # Low-level measures + AbstractGauge.F90 + MpiTimerGauge.F90 + FortranTimerGauge.F90 + RssMemoryGauge.F90 + VmstatMemoryGauge.F90 + + + + AdvancedMeter.F90 + DistributedMeter.F90 + + MeterNode.F90 + + AbstractColumn.F90 + SimpleColumn.F90 + TextColumn.F90 + SimpleTextColumn.F90 + NameColumn.F90 + + FormattedTextColumn.F90 + MemoryTextColumn.F90 + SeparatorColumn.F90 + NumCyclesColumn.F90 + InclusiveColumn.F90 + ExclusiveColumn.F90 + StdDevColumn.F90 + MinCycleColumn.F90 + MeanCycleColumn.F90 + MaxCycleColumn.F90 + MinCycleColumn.F90 + PercentageColumn.F90 + ColumnVector.F90 + TextColumnVector.F90 + MultiColumn.F90 + + BaseProfiler.F90 + TimeProfiler.F90 + MemoryProfiler.F90 + DistributedProfiler.F90 + ProfileReporter.F90 + + # The package + MAPL_Profiler.F90 + + ) +esma_add_library (${this} SRCS ${srcs} DEPENDENCIES gftl-shared gftl MPI::MPI_Fortran) +target_include_directories (${this} PRIVATE ${MAPL_SOURCE_DIR}/include) + +add_subdirectory (demo) +if (PFUNIT_FOUND) + add_subdirectory (tests) +endif () + + diff --git a/MAPL_Profiler/ColumnVector.F90 b/MAPL_Profiler/ColumnVector.F90 new file mode 100644 index 000000000000..65842667219c --- /dev/null +++ b/MAPL_Profiler/ColumnVector.F90 @@ -0,0 +1,10 @@ +module MAPL_ColumnVector + use MAPL_AbstractColumn + +#define _type class(AbstractColumn) +#define _allocatable +#define _vector ColumnVector +#define _iterator ColumnVectorIterator +#include "templates/vector.inc" + +end module MAPL_ColumnVector diff --git a/MAPL_Profiler/DistributedMeter.F90 b/MAPL_Profiler/DistributedMeter.F90 new file mode 100644 index 000000000000..d661dca85873 --- /dev/null +++ b/MAPL_Profiler/DistributedMeter.F90 @@ -0,0 +1,367 @@ +module MAPL_DistributedMeter + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AdvancedMeter + use MAPL_AbstractGauge + use MPI + implicit none + private + + public :: DistributedMeter + public :: DistributedReal64 + public :: DistributedInteger + public :: DistributedStatistics + public :: operator(.reduce.) + + interface operator(.reduce.) + module procedure reduce_distributed_real64 + module procedure reduce_distributed_integer + module procedure reduce_distributed_data + end interface + + type :: DistributedReal64 + sequence + real(kind=REAL64) :: total = 0 + real(kind=REAL64) :: min = huge(1._REAL64) + real(kind=REAL64) :: max = -huge(1._REAL64) + integer :: min_pe = huge(1) + integer :: max_pe = -1 + integer :: num_pes = 1 + integer :: pad + end type DistributedReal64 + + type :: DistributedInteger + sequence + integer :: total = 0 + integer :: min + integer :: max + integer :: min_pe = huge(1) + integer :: max_pe = -1 + integer :: num_pes = 1 + end type DistributedInteger + + type :: DistributedStatistics + sequence + type(DistributedReal64) :: total + type(DistributedReal64) :: exclusive + type(DistributedReal64) :: min_cycle + type(DistributedReal64) :: max_cycle + type(DistributedReal64) :: mean_cycle + type(DistributedReal64) :: sum_square_deviation + type(DistributedInteger) :: num_cycles + end type DistributedStatistics + + type, extends(AdvancedMeter) :: DistributedMeter + private + type(DistributedStatistics) :: statistics + contains + !procedure :: reduce_global + procedure :: reduce_mpi + generic :: reduce => reduce_mpi !,reduce_global + + procedure :: get_statistics + procedure :: get_stats_total + procedure :: get_stats_min_cycle + procedure :: get_stats_max_cycle + procedure :: get_stats_num_cycles +!!$ procedure :: get_stats_sum_square_deviation + + procedure :: make_mpi_type_distributed_data + procedure :: make_mpi_type_distributed_real64 + procedure :: make_mpi_type_distributed_integer + generic :: make_mpi_type => make_mpi_type_distributed_data + generic :: make_mpi_type => make_mpi_type_distributed_real64 + generic :: make_mpi_type => make_mpi_type_distributed_integer + end type DistributedMeter + + + interface DistributedReal64 + module procedure :: new_DistributedReal64 + end interface DistributedReal64 + + interface DistributedInteger + module procedure :: new_DistributedInteger + end interface DistributedInteger + + interface DistributedMeter + module procedure :: new_DistributedMeter + end interface DistributedMeter + + + logical, save :: initialized = .false. + + integer, save :: mpi_dist_type + integer, save :: mpi_reduce_op + +contains + + function new_DistributedReal64(value, rank) result(distributed_real64) + type(DistributedReal64) :: distributed_real64 + real(kind=REAL64), intent(in) :: value + integer, intent(in) :: rank + + distributed_real64%total = value + distributed_real64%min = value + distributed_real64%max = value + distributed_real64%min_pe = rank + distributed_real64%max_pe = rank + distributed_real64%num_pes = 1 + + end function new_DistributedReal64 + + function new_DistributedInteger(value, rank) result(distributed_integer) + type(DistributedInteger) :: distributed_integer + integer, intent(in) :: value + integer, intent(in) :: rank + + distributed_integer%total = value + distributed_integer%min = value + distributed_integer%max = value + distributed_integer%min_pe = rank + distributed_integer%max_pe = rank + distributed_integer%num_pes = 1 + end function new_DistributedInteger + + + function new_DistributedMeter(gauge) result(distributed_meter) + type(DistributedMeter) :: distributed_meter + class(AbstractGauge), intent(in) :: gauge + + integer :: ierror + + if (.not. initialized) then + call initialize(ierror) + initialized = .true. + end if + + distributed_meter%AdvancedMeter = AdvancedMeter(gauge) + + end function new_DistributedMeter + + subroutine initialize(ierror) + integer, intent(out) :: ierror + + type (DistributedMeter) :: dummy + logical :: commute + + call dummy%make_mpi_type(dummy%statistics, mpi_dist_type, ierror) + call MPI_Type_commit(mpi_dist_type, ierror) + + commute = .true. + call MPI_Op_create(true_reduce, commute, mpi_reduce_op, ierror) + + end subroutine initialize + + function get_statistics(this) result(statistics) + type (DistributedStatistics) :: statistics + class (DistributedMeter), intent(in) :: this + statistics = this%statistics + end function get_statistics + + function reduce_distributed_real64(a, b) result(c) + type(DistributedReal64) :: c + type(DistributedReal64), intent(in) :: a + type(DistributedReal64), intent(in) :: b + + c%total = a%total + b%total + + if (b%min < a%min) then + c%min_pe = b%min_pe + elseif (a%min < b%min) then + c%min_pe = a%min_pe + else ! tie + c%min_pe = min(a%min_pe, b%min_pe) + end if + c%min = min(a%min, b%min) + + if (b%max > a%max) then + c%max_pe = b%max_pe + elseif (a%max > b%max) then + c%max_pe = a%max_pe + else ! tie + c%max_pe = min(a%max_pe, b%max_pe) + end if + c%max = max(a%max, b%max) + + c%num_pes = a%num_pes + b%num_pes + + end function reduce_distributed_real64 + + + function reduce_distributed_integer(a, b) result(c) + type(DistributedInteger) :: c + type(DistributedInteger), intent(in) :: a + type(DistributedInteger), intent(in) :: b + + c%total = a%total + b%total + + if (b%min < a%min) then + c%min_pe = b%min_pe + elseif (a%min < b%min) then + c%min_pe = a%min_pe + else ! tie + c%min_pe = min(a%min_pe, b%min_pe) + end if + c%min = min(a%min, b%min) + + if (b%max > a%max) then + c%max_pe = b%max_pe + elseif (a%max < b%max) then + c%max_pe = a%max_pe + else ! tie + c%max_pe = min(a%max_pe, b%max_pe) + end if + c%max = max(a%max, b%max) + + c%num_pes = a%num_pes + b%num_pes + + end function reduce_distributed_integer + + + function reduce_distributed_data(a, b) result(c) + type(DistributedStatistics) :: c + type(DistributedStatistics), intent(in) :: a + type(DistributedStatistics), intent(in) :: b + + c%total = a%total .reduce. b%total + c%exclusive = a%exclusive .reduce. b%exclusive + c%min_cycle = a%min_cycle .reduce. b%min_cycle + + c%max_cycle = a%max_cycle .reduce. b%max_cycle + c%sum_square_deviation = a%sum_square_deviation .reduce. b%sum_square_deviation + c%num_cycles = a%num_cycles .reduce. b%num_cycles + + end function reduce_distributed_data + + + function get_stats_total(this) result(total) + type(DistributedReal64) :: total + class(DistributedMeter), intent(in) :: this + + total = this%statistics%total + end function get_stats_total + + function get_stats_min_cycle(this) result(min_cycle) + type(DistributedReal64) :: min_cycle + class(DistributedMeter), intent(in) :: this + + min_cycle = this%statistics%min_cycle + end function get_stats_min_cycle + + function get_stats_max_cycle(this) result(max_cycle) + type(DistributedReal64) :: max_cycle + class(DistributedMeter), intent(in) :: this + + max_cycle = this%statistics%max_cycle + end function get_stats_max_cycle + + function get_stats_num_cycles(this) result(num_cycles) + type(DistributedInteger) :: num_cycles + class(DistributedMeter), intent(in) :: this + + num_cycles = this%statistics%num_cycles + end function get_stats_num_cycles + + + subroutine reduce_global(this, exclusive) + class(DistributedMeter), intent(inout) :: this + real(kind=REAL64), intent(in) :: exclusive + call this%reduce(MPI_COMM_WORLD, exclusive) + end subroutine reduce_global + + + subroutine reduce_mpi(this, comm, exclusive) + class(DistributedMeter), intent(inout) :: this + integer, intent(in) :: comm + real(kind=REAL64), intent(in) :: exclusive + + integer :: ierror + + integer :: dist_type + integer :: rank + type(DistributedStatistics) :: tmp, tmp2 + + call MPI_Comm_rank(comm, rank, ierror) + + this%statistics%total = DistributedReal64(this%get_total(), rank) + this%statistics%exclusive = DistributedReal64(exclusive, rank) + this%statistics%min_cycle = DistributedReal64(this%get_min_cycle(), rank) + this%statistics%max_cycle = DistributedReal64(this%get_max_cycle(), rank) + this%statistics%sum_square_deviation = DistributedReal64(this%get_sum_square_deviation(), rank) + this%statistics%num_cycles = DistributedInteger(this%get_num_cycles(), rank) + + tmp = this%statistics + call MPI_Reduce(tmp, this%statistics, 1, mpi_dist_type, mpi_reduce_op, 0, comm, ierror) + + end subroutine reduce_mpi + + + subroutine make_mpi_type_distributed_real64(this, r64, new_type, ierror) + class (DistributedMeter), intent(in) :: this + type (DistributedReal64), intent(in) :: r64 ! used only for generic resolution + integer, intent(out) :: new_type + integer, intent(out) :: ierror + + integer(kind=MPI_ADDRESS_KIND) :: displacements(2) + integer(kind=MPI_ADDRESS_KIND) :: lb, sz + + call MPI_Type_get_extent_x(MPI_REAL8, lb, sz, ierror) + displacements = [0_MPI_ADDRESS_KIND, 3*sz] + + call MPI_Type_create_struct(2, [3,4], displacements, [MPI_REAL8, MPI_INTEGER], new_type, ierror) + + end subroutine make_mpi_type_distributed_real64 + + + subroutine make_mpi_type_distributed_integer(this, int, new_type, ierror) + class (DistributedMeter), intent(in) :: this + type (DistributedInteger), intent(in) :: int ! used only for generic resolution + integer, intent(out) :: new_type + integer, intent(out) :: ierror + + integer(kind=MPI_ADDRESS_KIND) :: displacements(1) + + displacements = [0_MPI_ADDRESS_KIND] + call MPI_Type_create_struct(1, [6], displacements, [MPI_INTEGER], new_type, ierror) + + end subroutine make_mpi_type_distributed_integer + + + subroutine make_mpi_type_distributed_data(this, d, new_type, ierror) + class (DistributedMeter), intent(in) :: this + type (DistributedStatistics), intent(in) :: d ! used only for generic resolution + integer, intent(out) :: new_type + integer, intent(out) :: ierror + + integer(kind=MPI_ADDRESS_KIND) :: displacements(2) + integer(kind=MPI_ADDRESS_KIND) :: lb, sz, sz2 + integer :: type_dist_real64, type_dist_integer + + call this%make_mpi_type(this%statistics%total, type_dist_real64, ierror) + call this%make_mpi_type(this%statistics%num_cycles, type_dist_integer, ierror) + + call MPI_Type_get_extent_x(type_dist_real64, lb, sz, ierror) + displacements = [0_MPI_ADDRESS_KIND, 6*sz] + call MPI_Type_create_struct(2, [6,1], displacements, [type_dist_real64, type_dist_integer], new_type, ierror) + call MPI_Type_get_extent_x(new_type, lb, sz2, ierror) + + end subroutine make_mpi_type_distributed_data + + + + subroutine true_reduce(invec, inoutvec, len, type) + integer, intent(in) :: len + type(DistributedStatistics), intent(in) :: invec(len) + type(DistributedStatistics), intent(inout) :: inoutvec(len) + integer, intent(in) :: type + + integer :: i + + do i = 1, len + inoutvec(i) = invec(i) .reduce. inoutvec(i) + end do + + end subroutine true_reduce + +end module MAPL_DistributedMeter + + diff --git a/MAPL_Profiler/DistributedMeterNode.F90 b/MAPL_Profiler/DistributedMeterNode.F90 new file mode 100644 index 000000000000..471eb57c5f08 --- /dev/null +++ b/MAPL_Profiler/DistributedMeterNode.F90 @@ -0,0 +1,22 @@ +module MAP_DistributedMeterNode + implicit none + private + + public :: DistributedMeterNode + + + interface DistributedMeterNode + module procedure new_DistributedMeterNode + end interface DistributedMeterNode + + +contains + + + function new_DistributedMeterNode(meter_node, comm) result(distributed_meter_node) + class (AbstractMeterNode), intent(in) :: meter_node + integer, intent(in) :: comm ! mpi _communicator + + end function new_DistributedMeterNode + +end module MAP_DistributedMeterNode diff --git a/MAPL_Profiler/DistributedProfiler.F90 b/MAPL_Profiler/DistributedProfiler.F90 new file mode 100644 index 000000000000..aae4448c66b7 --- /dev/null +++ b/MAPL_Profiler/DistributedProfiler.F90 @@ -0,0 +1,98 @@ +module MAPL_DistributedProfiler + use MAPL_AbstractMeter + use MAPL_AbstractGauge + use MAPL_AbstractMeterNode + use MAPL_MeterNode + use MAPL_BaseProfiler + use Mapl_DistributedMeter + + use MAPL_AdvancedMeter + use MAPL_MpiTimerGauge + implicit none + private + + public :: DistributedProfiler + + type, extends(BaseProfiler) :: DistributedProfiler + private + class(AbstractGauge), allocatable :: gauge + integer :: comm = -1 + contains + procedure :: make_meter + procedure :: reduce + procedure :: copy + end type DistributedProfiler + + interface DistributedProfiler + module procedure :: new_DistributedProfiler + end interface DistributedProfiler + + +contains + + + function new_DistributedProfiler(name, gauge, comm, comm_world) result(distributed_profiler) + type(DistributedProfiler), target :: distributed_profiler + character(*), intent(in) :: name + class(AbstractGauge), intent(in) :: gauge + integer, intent(in) :: comm + integer, optional, intent(in) :: comm_world + + distributed_profiler%gauge = gauge + distributed_profiler%comm = comm + + call distributed_profiler%set_comm_world(comm_world = comm_world) + call distributed_profiler%set_node(MeterNode(name, distributed_profiler%make_meter())) + call distributed_profiler%start() + + end function new_DistributedProfiler + + + function make_meter(this) result(meter) + class(AbstractMeter), allocatable :: meter + class(DistributedProfiler), intent(in) :: this + + meter = DistributedMeter(this%gauge) +!!$ meter = DistributedMeter(MpiTimerGauge()) + end function make_meter + + + subroutine reduce(this) + class(DistributedProfiler), target, intent(inout) :: this + + class(AbstractMeterNodeIterator), target, allocatable :: iter + class(AbstractMeterNode), pointer :: root, node + class(AbstractMeter), pointer :: m + + root => this%get_root_node() + iter = root%begin() + do while (iter /= root%end()) + node => iter%get() + m => iter%get_meter() + + select type (m) + class is (DistributedMeter) + call m%reduce(this%comm, node%get_exclusive()) + class default + print*,'error - wrong type (other)' + end select + + call iter%next() + end do + + end subroutine reduce + + subroutine copy(new, old) + class(DistributedProfiler), target, intent(inout) :: new + class(BaseProfiler), target, intent(in) :: old + + call new%copy_profiler(old) + select type (old) + class is (DistributedProfiler) + new%gauge = old%gauge + new%comm = old%comm + end select + + end subroutine copy + +end module MAPL_DistributedProfiler diff --git a/MAPL_Profiler/ExclusiveColumn.F90 b/MAPL_Profiler/ExclusiveColumn.F90 new file mode 100644 index 000000000000..967066af7b25 --- /dev/null +++ b/MAPL_Profiler/ExclusiveColumn.F90 @@ -0,0 +1,73 @@ +module MAPL_ExclusiveColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractColumn + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use Mapl_DistributedMeter + implicit none + private + + public :: ExclusiveColumn + + type, extends(SimpleColumn) :: ExclusiveColumn + private + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type ExclusiveColumn + + interface ExclusiveColumn + module procedure :: new_ExclusiveColumn + end interface ExclusiveColumn + + +contains + + + function new_ExclusiveColumn(option) result(column) + type(ExclusiveColumn) :: column + character(*), optional, intent(in) :: option + if (present(option)) column%option = option + end function new_ExclusiveColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (ExclusiveColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + + if (.not. allocated(this%option)) then + allocate(row, source=node%get_exclusive()) + else + call this%get_row_dist(node, row) + end if + + end function get_row + + + subroutine get_row_dist(this, node, row) + class(*), allocatable, intent(out) :: row + class (ExclusiveColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: exclusive + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + exclusive = stats%exclusive + call this%fill_row(exclusive, this%option, row) + end select + + end subroutine get_row_dist + +end module MAPL_ExclusiveColumn + + diff --git a/MAPL_Profiler/FormattedTextColumn.F90 b/MAPL_Profiler/FormattedTextColumn.F90 new file mode 100644 index 000000000000..04e6ef1847fa --- /dev/null +++ b/MAPL_Profiler/FormattedTextColumn.F90 @@ -0,0 +1,124 @@ +module MAPL_FormattedTextColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractColumn + use MAPL_AbstractMeterNode + use MAPL_TextColumn + use GFTL_UnlimitedVector + implicit none + private + + public :: FormattedTextColumn + + type, extends(TextColumn) :: FormattedTextColumn + private + + character(:), allocatable :: header(:) + character(:), allocatable :: format + class (AbstractColumn), allocatable :: data_column + contains + procedure :: get_header + procedure :: get_rows + procedure :: get_num_rows_header + end type FormattedTextColumn + + + interface FormattedTextColumn + module procedure new_FormattedTextColumn_scalar_header + module procedure new_FormattedTextColumn_array_header + end interface FormattedTextColumn + + +contains + + + function new_FormattedTextColumn_scalar_header(header, format, width, data_column, separator) result(column) + type (FormattedTextColumn) :: column + character(*), intent(in) :: header + character(*), intent(in) :: format + integer, intent(in) :: width + class (AbstractColumn), intent(in) :: data_column + character(1), optional :: separator + + column = FormattedTextColumn([header], format, width, data_column, separator=separator) + + end function new_FormattedTextColumn_scalar_header + + + function new_FormattedTextColumn_array_header(header, format, width, data_column, separator) result(column) + type (FormattedTextColumn) :: column + character(*), intent(in) :: header(:) + character(*), intent(in) :: format + integer, intent(in) :: width + class (AbstractColumn), intent(in) :: data_column + character(1), optional :: separator + + column%header = header + column%format = format + call column%set_width(width) + column%data_column = data_column + + if (present(separator)) then + call column%set_separator(separator) + end if + + end function new_FormattedTextColumn_array_header + + + + subroutine get_header(this, header) + class (FormattedTextColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + + integer :: w, n, n0 + integer :: i + + w = this%get_width() + n0 = size(this%header) + n = this%get_num_rows_header() + allocate(character(w) :: header(n)) + + do i = 1, n0 + header(i)(:) = this%header(i) + end do + + if (n>n0) call this%get_separator(header(n0+1), n-n0) + call this%center(header) + + end subroutine get_header + + integer function get_num_rows_header(this) result(num_rows) + class(FormattedTextColumn), intent(in) :: this + + num_rows = size(this%header) + this%get_num_rows_separator() + + end function get_num_rows_header + + + subroutine get_rows(this, node, rows) + use MAPL_AbstractMeterNode + class (FormattedTextColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + character(:), allocatable, intent(out) :: rows(:) + + type (UnlimitedVector) :: values + + integer :: i, n + + values = this%data_column%get_rows(node) + + n = this%get_width() + allocate(character(n) :: rows(values%size())) + + do i = 1, values%size() + select type (v => values%at(i)) + type is (integer) + write(rows(i),this%format) v + type is (real(kind=REAL64)) + write(rows(i),this%format) v + end select + end do + + end subroutine get_rows + + +end module MAPL_FormattedTextColumn diff --git a/MAPL_Profiler/FortranTimerGauge.F90 b/MAPL_Profiler/FortranTimerGauge.F90 new file mode 100644 index 000000000000..bdb1949fcb37 --- /dev/null +++ b/MAPL_Profiler/FortranTimerGauge.F90 @@ -0,0 +1,47 @@ +module MAPL_FortranTimerGauge + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 + use MAPL_AbstractGauge + implicit none + private + + public :: FortranTimerGauge + + type, extends(AbstractGauge) :: FortranTimerGauge + private + real(kind=REAL64) :: denominator + contains + procedure :: get_measurement + end type FortranTimerGauge + + interface FortranTimerGauge + module procedure :: new_FortranTimerGauge + end interface FortranTimerGauge + + +contains + + + function new_FortranTimerGauge() result(gauge) + type (FortranTimerGauge) :: gauge + integer(kind=REAL64) :: count_rate + + call system_clock(count_rate=count_rate) + gauge%denominator = 1._REAL64/count_rate + + end function new_FortranTimerGauge + + + ! TODO: compute denomintor once during initialization + function get_measurement(this) result(measurement) + real(kind=REAL64) :: measurement + class(FortranTimerGauge), intent(inout) :: this + + integer(kind=INT64) :: tick, rate + call system_clock(count=tick, count_rate=rate) + + measurement = tick * this%denominator + + end function get_measurement + + +end module MAPL_FortranTimerGauge diff --git a/MAPL_Profiler/InclusiveColumn.F90 b/MAPL_Profiler/InclusiveColumn.F90 new file mode 100644 index 000000000000..b792b258ff98 --- /dev/null +++ b/MAPL_Profiler/InclusiveColumn.F90 @@ -0,0 +1,71 @@ +module MAPL_InclusiveColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractColumn + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use Mapl_DistributedMeter + implicit none + private + + public :: InclusiveColumn + + type, extends(SimpleColumn) :: InclusiveColumn + private + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type InclusiveColumn + + interface InclusiveColumn + module procedure :: new_InclusiveColumn + end interface InclusiveColumn + + +contains + + + function new_InclusiveColumn(option) result(column) + type(InclusiveColumn) :: column + character(*), optional, intent(in) :: option + if (present(option)) column%option = option + end function new_InclusiveColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (InclusiveColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + if (.not. allocated(this%option)) then + allocate(row, source=node%get_inclusive()) + else + call this%get_row_dist(node, row) + end if + + end function get_row + + + subroutine get_row_dist(this, node, row) + class (InclusiveColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class(*), allocatable, intent(out) :: row + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: inclusive + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + inclusive = stats%total + + call this%fill_row(inclusive, this%option, row) + end select + + end subroutine get_row_dist + +end module MAPL_InclusiveColumn diff --git a/MAPL_Profiler/MAPL_Profiler.F90 b/MAPL_Profiler/MAPL_Profiler.F90 new file mode 100644 index 000000000000..73479da34a43 --- /dev/null +++ b/MAPL_Profiler/MAPL_Profiler.F90 @@ -0,0 +1,41 @@ +! Package exporter +module MAPL_Profiler + use MAPL_AbstractMeter + use MAPL_AbstractMeterNode + use MAPL_AbstractMeterFactory + use MAPL_MeterNodeVector + use MAPL_MeterNode + use MAPL_BaseProfiler + + use MAPL_AdvancedMeter + use MAPL_MpiTimerGauge + use MAPL_FortranTimerGauge + use MAPL_RssMemoryGauge + use MAPL_VmstatMemoryGauge + + use MAPL_AbstractColumn + use MAPL_SimpleColumn + use MAPL_TextColumn + use MAPL_SimpleTextColumn + use MAPL_FormattedTextColumn + use MAPL_MemoryTextColumn + use MAPL_NameColumn + use MAPL_NumCyclesColumn + use MAPL_InclusiveColumn + use MAPL_ExclusiveColumn + use MAPL_StdDevColumn + use MAPL_MinCycleColumn + use MAPL_MaxCycleColumn + use MAPL_MeanCycleColumn + use MAPL_PercentageColumn + use MAPL_TextColumnVector + use MAPL_MultiColumn + + use MAPL_TimeProfiler + use MAPL_MemoryProfiler + use MAPL_ProfileReporter + use MAPL_DistributedMeter + use MAPL_DistributedProfiler + implicit none + +end module MAPL_Profiler diff --git a/MAPL_Profiler/MaxCycleColumn.F90 b/MAPL_Profiler/MaxCycleColumn.F90 new file mode 100644 index 000000000000..af3ea6838e0c --- /dev/null +++ b/MAPL_Profiler/MaxCycleColumn.F90 @@ -0,0 +1,79 @@ +module MAPL_MaxCycleColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use MAPL_AdvancedMeter + use Mapl_DistributedMeter + implicit none + private + + public :: MaxCycleColumn + + type, extends(SimpleColumn) :: MaxCycleColumn + private + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type MaxCycleColumn + + interface MaxCycleColumn + module procedure :: new_MaxCycleColumn + end interface MaxCycleColumn + + +contains + + + function new_MaxCycleColumn(option) result(column) + type(MaxCycleColumn) :: column + character(*), optional, intent(in) :: option + if (present(option)) column%option = option + end function new_MaxCycleColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (MaxCycleColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class (AbstractMeter), pointer :: tmr + + tmr => node%get_meter() + select type (tmr) + class is (AdvancedMeter) + if (.not. allocated(this%option)) then + allocate(row, source=tmr%get_max_cycle()) + else + call this%get_row_dist(node, row) + end if + end select + + end function get_row + + + subroutine get_row_dist(this, node, row) + class (MaxCycleColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class(*), allocatable, intent(out) :: row + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: max_cycle + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + max_cycle = stats%max_cycle + + call this%fill_row(max_cycle, this%option, row) + + end select + + end subroutine get_row_dist + +end module MAPL_MaxCycleColumn + + diff --git a/MAPL_Profiler/MeanCycleColumn.F90 b/MAPL_Profiler/MeanCycleColumn.F90 new file mode 100644 index 000000000000..4082d9b6204b --- /dev/null +++ b/MAPL_Profiler/MeanCycleColumn.F90 @@ -0,0 +1,80 @@ +module MAPL_MeanCycleColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use MAPL_AdvancedMeter + use Mapl_DistributedMeter + implicit none + private + + public :: MeanCycleColumn + + type, extends(SimpleColumn) :: MeanCycleColumn + private + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type MeanCycleColumn + + interface MeanCycleColumn + module procedure :: new_MeanCycleColumn + end interface MeanCycleColumn + + +contains + + + function new_MeanCycleColumn(option) result(column) + type(MeanCycleColumn) :: column + character(*), optional, intent(in) :: option + if (present(option)) column%option = option + end function new_MeanCycleColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (MeanCycleColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class (AbstractMeter), pointer :: tmr + + tmr => node%get_meter() + select type (tmr) + class is (AdvancedMeter) + if (.not. allocated(this%option)) then + allocate(row, source=tmr%get_mean_cycle()) + else + call this%get_row_dist(node, row) + end if + end select + + end function get_row + + + subroutine get_row_dist(this, node, row) + class (MeanCycleColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class(*), allocatable, intent(out) :: row + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: mean_cycle + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + mean_cycle = stats%mean_cycle + + call this%fill_row(mean_cycle, this%option, row) + + end select + + end subroutine get_row_dist + +end module MAPL_MeanCycleColumn + + + diff --git a/MAPL_Profiler/MemoryProfiler.F90 b/MAPL_Profiler/MemoryProfiler.F90 new file mode 100644 index 000000000000..1607c1eee3d0 --- /dev/null +++ b/MAPL_Profiler/MemoryProfiler.F90 @@ -0,0 +1,141 @@ +module MAPL_MemoryProfiler_private + use MAPL_BaseProfiler, only: BaseProfiler + use MAPL_BaseProfiler, only: MemoryProfilerIterator => BaseProfilerIterator + + use MAPL_RssMemoryGauge + use MAPL_VmstatMemoryGauge + use MAPL_AdvancedMeter + use MAPL_AbstractMeter + use MAPL_MeterNode + implicit none + private + + public :: MemoryProfiler + public :: MemoryProfilerIterator + public :: get_global_memory_profiler + + + type, extends(BaseProfiler) :: MemoryProfiler + private + contains + procedure :: make_meter + procedure :: copy + end type MemoryProfiler + + interface MemoryProfiler + module procedure new_MemoryProfiler + end interface MemoryProfiler + + type(MemoryProfiler), protected, target :: global_memory_profiler + +contains + + + function new_MemoryProfiler(name, comm_world) result(prof) + type(MemoryProfiler), target :: prof + character(*), intent(in) :: name + integer, optional, intent(in) :: comm_world + + call prof%set_comm_world(comm_world = comm_world) + call prof%set_node(MeterNode(name, prof%make_meter())) + call prof%start() + + end function new_MemoryProfiler + + function make_meter(this) result(meter) + class(AbstractMeter), allocatable :: meter + class(MemoryProfiler), intent(in) :: this + meter = AdvancedMeter(RssMemoryGauge()) +!!$ meter = AdvancedMeter(VmstatMemoryGauge()) + end function make_meter + + + function get_global_memory_profiler() result(memory_profiler) + type(MemoryProfiler), pointer :: memory_profiler + + memory_profiler => global_memory_profiler + + end function get_global_memory_profiler + + + subroutine copy(new, old) + class(MemoryProfiler), target, intent(inout) :: new + class(BaseProfiler), target, intent(in) :: old + + call new%copy_profiler(old) + + end subroutine copy + + +end module MAPL_MemoryProfiler_private + + + +module MAPL_MemoryProfiler + use MAPL_BaseProfiler + use MAPL_MemoryProfiler_private + implicit none + private + + public :: MemoryProfiler + public :: MemoryProfilerIterator + public :: get_global_memory_profiler + public :: initialize + public :: finalize + public :: start + public :: stop + +contains + + subroutine initialize(name) + character(*), optional, intent(in) :: name + + type(MemoryProfiler), pointer :: memory_profiler + character(:), allocatable :: name_ + + if (present(name)) then + name_ = name + else + name_ = 'top' + end if + + memory_profiler => get_global_memory_profiler() + memory_profiler = MemoryProfiler(name_) + + end subroutine initialize + + + subroutine finalize() + + type(MemoryProfiler), pointer :: memory_profiler + + memory_profiler => get_global_memory_profiler() + call memory_profiler%finalize() + + end subroutine finalize + + + subroutine start(name) + character(*), intent(in) :: name + + type(MemoryProfiler), pointer :: memory_profiler + + memory_profiler => get_global_memory_profiler() + call memory_profiler%start(name) + + end subroutine start + + + subroutine stop(name) + character(*), intent(in) :: name + + type(MemoryProfiler), pointer :: memory_profiler + + memory_profiler => get_global_memory_profiler() + call memory_profiler%stop(name) + + end subroutine stop + + + +end module MAPL_MemoryProfiler diff --git a/MAPL_Profiler/MemoryTextColumn.F90 b/MAPL_Profiler/MemoryTextColumn.F90 new file mode 100644 index 000000000000..c067750d91f2 --- /dev/null +++ b/MAPL_Profiler/MemoryTextColumn.F90 @@ -0,0 +1,172 @@ +module MAPL_MemoryTextColumn + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 + use MAPL_AbstractColumn + use MAPL_AbstractMeterNode + use MAPL_TextColumn + use GFTL_UnlimitedVector + implicit none + private + + public :: MemoryTextColumn + + type String + character(:), allocatable :: string + end type String + type, extends(TextColumn) :: MemoryTextColumn + private +!!$ character(:), allocatable :: header(:) + type (String), allocatable :: header(:) + character(:), allocatable :: format + class (AbstractColumn), allocatable :: data_column + contains + procedure :: get_header + procedure :: get_num_rows_header + procedure :: get_rows + end type MemoryTextColumn + + + interface MemoryTextColumn + module procedure new_MemoryTextColumn + end interface MemoryTextColumn + + +contains + + + function new_MemoryTextColumn(header, format, width, data_column, separator) result(column) + type (MemoryTextColumn) :: column + character(*), intent(in) :: header(:) + character(*), intent(in) :: format + integer, intent(in) :: width + class (AbstractColumn), intent(in) :: data_column + character(1), optional, intent(in) :: separator + + integer :: i, n + character(:), allocatable :: word + + n = size(header) + allocate(column%header(n)) + do i = 1, n + column%header(i)%string = header(i) + end do + + column%format = format + call column%set_width(width) + + column%data_column = data_column + + if (present(separator)) then + call column%set_separator(separator) + end if + + + end function new_MemoryTextColumn + + + + subroutine get_header(this, header) + class (MemoryTextColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + integer :: w, n + integer :: i + + w = this%get_width() + n = this%get_num_rows_header() + allocate(character(w) :: header(n)) + do i = 1, size(this%header) + header(i)(:) = this%header(i)%string + end do + call this%get_separator(header(size(this%header)+1), n - size(this%header)) + call this%center(header) + + end subroutine get_header + + + integer function get_num_rows_header(this) result(num_rows) + class(MemoryTextColumn), intent(in) :: this + num_rows = size(this%header) + this%get_num_rows_separator() + end function get_num_rows_header + + + subroutine get_rows(this, node, rows) + use MAPL_AbstractMeterNode + class (MemoryTextColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + character(:), allocatable, intent(out) :: rows(:) + + integer :: n, i + character(2) :: suffix + real(kind=REAL64) :: x + type (UnlimitedVector) :: values + + n = this%get_width() + + values = this%data_column%get_rows(node) + allocate(character(n) :: rows(values%size())) + + do i = 1, values%size() + select type (v => values%at(i)) + type is (integer) + x = real(v, kind=REAL64) + suffix = get_suffix(x) + write(rows(i),this%format) convert(x), suffix + type is (real(kind=REAL64)) + suffix = get_suffix(v) + write(rows(i),this%format) convert(v), suffix + end select + end do + + contains + + + function get_suffix(x) result(suffix) + character(2) :: suffix + real(kind=REAL64), intent(in) :: x + + integer(kind=INT64) :: ix + integer(kind=INT64) :: KB = 1024 + + ix = ceiling(abs(x)) + if (ix < KB) then + suffix = ' B' + elseif (ix < KB**2) then + suffix = 'KB' + elseif (ix < KB**3) then + suffix = 'MB' + elseif (ix < KB**4) then + suffix = 'GB' + else + suffix = 'TB' + end if + + end function get_suffix + + function convert(x) result(ix) + integer(kind=INT64) :: ix + real(kind=REAL64), intent(in) :: x + + + integer(kind=INT64) :: KB = 1024 + + ix = ceiling(abs(x)) + + if (ix < KB) then + ix = ix + elseif (ix < KB**2) then + ix = ix / KB + elseif (ix < KB**3) then + ix = ix / KB**2 + elseif (ix < KB**4) then + ix = ix / KB**3 + else + ix = ix / KB**4 + end if + + ix = sign(1.d0, x) * ix + + end function convert + + end subroutine get_rows + + +end module MAPL_MemoryTextColumn diff --git a/MAPL_Profiler/MeterNode.F90 b/MAPL_Profiler/MeterNode.F90 new file mode 100644 index 000000000000..dac0f4dd8a52 --- /dev/null +++ b/MAPL_Profiler/MeterNode.F90 @@ -0,0 +1,440 @@ +module MAPL_MeterNode + use, intrinsic :: iso_fortran_env, only: REAL64, REAL128 + use MAPL_AbstractMeter + use MAPL_AbstractMeterNode + use MAPL_MeterNodeVector + implicit none + private + + public :: MeterNode + public :: MeterNodeIterator + + type, extends(AbstractMeterNode) :: MeterNode + private + + ! Node data + class(AbstractMeter), allocatable :: meter + character(:), allocatable :: name + + ! Tree structure + integer :: depth + type (MeterNodeVector) :: children + integer :: last_child_accessed = 0 + + contains + procedure :: get_meter + procedure :: get_name + procedure :: get_depth + procedure :: get_inclusive + procedure :: get_exclusive + procedure :: add_child + procedure :: find_child + procedure :: get_child + procedure :: has_child + procedure :: get_num_nodes + procedure :: get_num_children + + procedure :: accumulate + procedure :: reset + + procedure :: begin + procedure :: end + end type MeterNode + + + type, extends(AbstractMeterNodeIterator) :: MeterNodeIterator + private + class (MeterNode), pointer :: reference => null() + class (AbstractMeterNode), pointer :: current => null() + + ! Subiterators are allocated after iterator goes beyond the root node + type (MeterNodeVectorIterator), allocatable :: iterator_over_children + class (AbstractMeterNodeIterator), allocatable :: iterator_of_current_child + contains + procedure :: get + procedure :: get_name => get_name_iter + procedure :: get_meter => get_meter_iter + procedure :: equals + procedure :: not_equals + procedure :: next + end type MeterNodeIterator + + + interface MeterNode + module procedure new_MeterNode + end interface MeterNode + + interface MeterNodeIterator + module procedure new_MeterNodeIterator + end interface MeterNodeIterator + + + integer, parameter :: NOT_FOUND = -1 + +contains + + + function new_MeterNode(name, meter, depth) result(tree) + type (MeterNode) :: tree + character(*), intent(in) :: name + class(AbstractMeter), intent(in) :: meter + integer, optional, intent(in) :: depth + + tree%name = name + tree%meter = meter + + if (present(depth)) then + tree%depth = depth + else + tree%depth = 0 + end if + + tree%last_child_accessed = 0 + + end function new_MeterNode + + + function get_meter(this) result(meter) + class (AbstractMeter), pointer :: meter + class (MeterNode), target, intent(in) :: this + meter => this%meter + end function get_meter + + + function get_name(this) result(name) + character(:), pointer :: name + class (MeterNode), target, intent(in) :: this + name => this%name + end function get_name + + + function get_inclusive(this) result(inclusive) + real(kind=REAL64) :: inclusive + class (MeterNode), intent(in) :: this + inclusive = this%meter%get_total() + end function get_inclusive + + + function get_exclusive(this) result(exclusive) + real(kind=REAL64) :: exclusive + class (MeterNode), intent(in) :: this + + type (MeterNodevectorIterator) :: iter + class (AbstractMeterNode), pointer :: child + real(kind=REAL128) :: tmp + + ! Subtract time of submeters from time of node meter. Note the + ! use of 128-bit precision to avoid negative exclusive times due + ! to roundoff. + tmp = this%get_inclusive() + + iter = this%children%begin() + do while (iter /= this%children%end()) + child => iter%get() + tmp = tmp - child%get_inclusive() + call iter%next() + end do + + exclusive = tmp + end function get_exclusive + + + subroutine add_child(this, name, meter) + class(MeterNode), target, intent(inout) :: this + character(*), intent(in) :: name + class(AbstractMeter), intent(in) :: meter + + class(AbstractMeterNode), pointer :: child + type (MeterNode) :: tmp + integer :: idx + + idx = this%find_child(name) + + if (idx == NOT_FOUND) then ! really add child + tmp = MeterNode(name, meter, this%get_depth()+1) + call this%children%push_back(tmp) + ! Note: last still references the previous child because we are likely + ! to follow this call with a get_child(), which should then be the 1st child + ! tested. + this%last_child_accessed = this%children%size() - 1 + else + ! node exists - makes it easier on client code to not throw + ! an exception here. + end if + + end subroutine add_child + + + function get_depth(this) result(depth) + integer :: depth + class (MeterNode), intent(in) :: this + depth = this%depth + end function get_depth + + + ! TODO: needs return code for failure + function get_child(this, name) result(child) + class (AbstractMeterNode), pointer :: child + class (MeterNode), target, intent(inout) :: this + character(*), intent(in) :: name + + integer :: idx + + idx = this%find_child(name) + if (idx /= NOT_FOUND) then + child => this%children%at(idx) + this%last_child_accessed = idx + else + child => null() + this%last_child_accessed = 0 + end if + + end function get_child + + ! We search by starting just after the last child accessed. The + ! theory is that meters are usually accessed cyclically in the same + ! order as they are first created. This is why the children + ! are stored as a vector rather than a map with the names as keys. + integer function find_child(this, name) result(idx) + class (MeterNode), intent(in) :: this + character(*), intent(in) :: name + + integer :: i, ii, n + class (AbstractMeterNode), pointer :: t + + n = this%children%size() + do i = 1, n + ii = 1 + mod(i + this%last_child_accessed - 1, n) + t => this%children%at(ii) + select type (t) + class is (MeterNode) + if (name == t%name) then + idx = ii + return + end if + class default + print*,'insert error handler' + end select + end do + + idx = NOT_FOUND + + end function find_child + + logical function has_child(this, name) + class (AbstractMeterNode), pointer :: child + class (MeterNode), target, intent(in) :: this + character(*), intent(in) :: name + has_child = (this%find_child(name) /= NOT_FOUND) + end function has_child + + + recursive integer function get_num_nodes(this) result(num_nodes) + class (MeterNode), target, intent(in) :: this + type (MeterNodeVectorIterator) :: iter + + class (AbstractMeterNode), pointer :: child + + num_nodes = 1 + iter = this%children%begin() + do while (iter /= this%children%end()) + child => iter%get() + num_nodes = num_nodes + child%get_num_nodes() + call iter%next() + end do + + end function get_num_nodes + + + integer function get_num_children(this) result(num_children) + class (MeterNode), target, intent(in) :: this + + num_children = this%children%size() + + end function get_num_children + + + + function new_MeterNodeIterator(meter_node) result(iterator) + type (MeterNode), target, intent(in) :: meter_node + type (MeterNodeIterator) :: iterator + + iterator%reference => meter_node + iterator%current => meter_node + + end function new_MeterNodeIterator + + + function begin(this) result(iterator) + class (AbstractMeterNodeIterator), allocatable :: iterator + class (MeterNode), target, intent(in) :: this + +!!$ iterator = MeterNodeIterator(this) + allocate(iterator, source=MeterNodeIterator(this)) + + end function begin + + + + function end(this) result(iterator) + class (AbstractMeterNodeIterator), allocatable :: iterator + class (MeterNode), target, intent(in) :: this + + type (MeterNodeIterator) :: tmp + + tmp = MeterNodeIterator(this) +!!$ iterator = MeterNodeIterator(this) + iterator = tmp + + select type (q => iterator) + class is (MeterNodeIterator) + q%current => null() + class default + print*,'uh oh' + end select + + end function end + + + recursive subroutine next(this) + class (MeterNodeIterator), intent(inout) :: this + class (AbstractMeterNode), pointer :: current_child + + + if (.not. associated(this%current)) return ! done + + if (.not. allocated(this%iterator_over_children)) then + this%iterator_over_children = this%reference%children%begin() + if (this%iterator_over_children /= this%reference%children%end()) then + current_child => this%iterator_over_children%get() + this%iterator_of_current_child = current_child%begin() + this%current => this%iterator_of_current_child%get() + else + this%current => null() + end if + else + call this%iterator_of_current_child%next() + this%current => this%iterator_of_current_child%get() + + if (.not. associated(this%current)) then ! go to next child + deallocate(this%iterator_of_current_child) + call this%iterator_over_children%next() + if (this%iterator_over_children == this%reference%children%end()) then ! done + deallocate(this%iterator_over_children) + else + current_child => this%iterator_over_children%get() + this%iterator_of_current_child = current_child%begin() ! always at least one node + this%current => this%iterator_of_current_child%get() + end if + end if + end if + + end subroutine next + + + function get(this) result(tree) + class (AbstractMeterNode), pointer :: tree + class (MeterNodeIterator), target, intent(in) :: this + tree => this%current + end function get + + + function get_meter_iter(this) result(t) + class (AbstractMeter), pointer :: t + class (MeterNodeIterator), intent(in) :: this + t => this%current%get_meter() + end function get_meter_iter + + + function get_name_iter(this) result(name) + character(:), pointer :: name + class (MeterNodeIterator), intent(in) :: this + name => this%current%get_name() + end function get_name_iter + + + logical function equals(a, b) + class (MeterNodeIterator), intent(in) :: a + class (AbstractMeterNodeIterator), intent(in) :: b + + + select type (b) + type is (MeterNodeIterator) + equals = associated(a%reference, b%reference) + if (.not. equals) return + + equals = associated(a%current) .eqv. associated(b%current) + if (.not. equals) return + + if (associated(a%current)) then + equals = associated(a%current, b%current) + if (.not. equals) return + end if + class default + equals = .false. + end select + + end function equals + + + logical function not_equals(a, b) + class (MeterNodeIterator), intent(in) :: a + class (AbstractMeterNodeIterator), intent(in) :: b + not_equals = .not. (a == b) + end function not_equals + + + ! Set all meters back to 0 + recursive subroutine reset(this) + class (MeterNode), target, intent(inout) :: this + type (MeterNodeVectorIterator) :: iter + class (AbstractMeterNode), pointer :: child + + call this%meter%reset + + iter = this%children%begin() + do while (iter /= this%children%end()) + child => iter%get() + call child%reset() + call iter%next() + end do + + end subroutine reset + + recursive subroutine accumulate(this, other) + class (MeterNode), intent(inout) :: this + class (AbstractMeterNode), target, intent(in) :: other + + class (AbstractMeterNode), pointer :: child + class (AbstractMeterNodeIterator), allocatable :: iter + class (AbstractMeter), pointer :: t + character(:), pointer :: name + + ! GFortran 8.2 complains about recursive call of nonrecursive + ! procedure (nested copy of data structure) + + + name => other%get_name() + child => this%get_child(name) + if (associated(child)) then + t => child%get_meter() + else + call this%add_child(name, this%get_meter()) + child => this%get_child(name) + t => child%get_meter() + call t%reset() + end if + call t%accumulate(other%get_meter()) + + ! recurse over children of other + iter = other%begin() + call iter%next() ! skip top node (already handled) + do while (iter /= other%end()) + call child%accumulate(iter%get()) + call iter%next() + end do + + end subroutine accumulate + + +end module MAPL_MeterNode diff --git a/MAPL_Profiler/MeterNodeStack.F90 b/MAPL_Profiler/MeterNodeStack.F90 new file mode 100644 index 000000000000..34f69ea4d089 --- /dev/null +++ b/MAPL_Profiler/MeterNodeStack.F90 @@ -0,0 +1,15 @@ +module MAPL_MeterNodeStack + use MAPL_AbstractMeterNode + +#define _type class (AbstractMeterNode) +#define _pointer +#define _vector MeterNodeStack +#define _iterator MeterNodeStackIterator +#include "templates/vector.inc" + +#undef _iterator +#undef _vector +#undef _pointer +#undef _type + +end module MAPL_MeterNodeStack diff --git a/MAPL_Profiler/MeterNodeVector.F90 b/MAPL_Profiler/MeterNodeVector.F90 new file mode 100644 index 000000000000..65abd6d43c30 --- /dev/null +++ b/MAPL_Profiler/MeterNodeVector.F90 @@ -0,0 +1,15 @@ +module MAPL_MeterNodeVector + use MAPL_AbstractMeterNode + +#define _type class (AbstractMeterNode) +#define _allocatable +#define _vector MeterNodeVector +#define _iterator MeterNodeVectorIterator +#include "templates/vector.inc" + +#undef _iterator +#undef _vector +#undef _pointer +#undef _type + +end module MAPL_MeterNodeVector diff --git a/MAPL_Profiler/MinCycleColumn.F90 b/MAPL_Profiler/MinCycleColumn.F90 new file mode 100644 index 000000000000..c66ba580aeeb --- /dev/null +++ b/MAPL_Profiler/MinCycleColumn.F90 @@ -0,0 +1,80 @@ +module MAPL_MinCycleColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use MAPL_AdvancedMeter + use Mapl_DistributedMeter + implicit none + private + + public :: MinCycleColumn + + type, extends(SimpleColumn) :: MinCycleColumn + private + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type MinCycleColumn + + interface MinCycleColumn + module procedure :: new_MinCycleColumn + end interface MinCycleColumn + + +contains + + + function new_MinCycleColumn(option) result(column) + type(MinCycleColumn) :: column + character(*), optional, intent(in) :: option + if (present(option)) column%option = option + end function new_MinCycleColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (MinCycleColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class (AbstractMeter), pointer :: tmr + + tmr => node%get_meter() + select type (tmr) + class is (AdvancedMeter) + if (.not. allocated(this%option)) then + allocate(row, source=tmr%get_min_cycle()) + else + call this%get_row_dist(node, row) + end if + end select + + end function get_row + + + subroutine get_row_dist(this, node, row) + class (MinCycleColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class(*), allocatable, intent(out) :: row + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: min_cycle + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + min_cycle = stats%min_cycle + + call this%fill_row(min_cycle, this%option, row) + + end select + + end subroutine get_row_dist + +end module MAPL_MinCycleColumn + + + diff --git a/MAPL_Profiler/MpiTimerGauge.F90 b/MAPL_Profiler/MpiTimerGauge.F90 new file mode 100644 index 000000000000..10532402654e --- /dev/null +++ b/MAPL_Profiler/MpiTimerGauge.F90 @@ -0,0 +1,42 @@ +#include "unused_dummy.H" + +module MAPL_MpiTimerGauge + use, intrinsic :: iso_fortran_env, only: REAL64 + use MPI, only: MPI_Wtime + use MAPL_AbstractGauge + implicit none + private + + public :: MpiTimerGauge + + type, extends(AbstractGauge) :: MpiTimerGauge + private + contains + procedure :: get_measurement + end type MpiTimerGauge + + interface MpiTimerGauge + module procedure :: new_MpiTimerGauge + end interface MpiTimerGauge + + +contains + + + ! Constructor is for convenience - avoids the need of naming a temp + ! variable when constructing advanced timers. + function new_MpiTimerGauge() result(gauge) + type (MpiTimerGauge) :: gauge + + end function new_MpiTimerGauge + + function get_measurement(this) result(measurement) + real(kind=REAL64) :: measurement + class(MpiTimerGauge), intent(inout) :: this + + _UNUSED_DUMMY(this) + measurement = MPI_Wtime() + + end function get_measurement + +end module MAPL_MpiTimerGauge diff --git a/MAPL_Profiler/MultiColumn.F90 b/MAPL_Profiler/MultiColumn.F90 new file mode 100644 index 000000000000..5221b9d449c9 --- /dev/null +++ b/MAPL_Profiler/MultiColumn.F90 @@ -0,0 +1,166 @@ +module MAPL_MultiColumn + use MAPL_TextColumn + use MAPL_TextColumnVector + use MAPL_AbstractMeterNode + use MAPL_SeparatorColumn + implicit none + private + + public :: MultiColumn + + type, extends(TextColumn) :: MultiColumn + private + type (TextColumnVector) :: columns + integer :: num_rows_header = 0 + character(:), allocatable :: shared_header(:) + contains + procedure :: add_column + procedure :: get_header + procedure :: get_num_rows_header + procedure :: get_rows + end type MultiColumn + + interface MultiColumn + module procedure :: new_MultiColumn + end interface MultiColumn + + +contains + + + function new_MultiColumn(header, separator) result(column) + character(*), intent(in) :: header(:) + type(MultiColumn) :: column + character(1), optional, intent(in) :: separator + + integer :: i, w, n + + w = len(header) + n = size(header) + allocate(character(w) :: column%shared_header(n)) + do i = 1, n + column%shared_header(i) = header(i) + end do + if (present(separator)) call column%set_separator(separator) + column%num_rows_header = column%get_num_rows_separator() + call column%set_width(0) + + end function new_MultiColumn + + + subroutine add_column(this, column) + class (MultiColumn), intent(inout) :: this + class (TextColumn), intent(in) :: column + + integer :: h, h0, w + + w = this%get_width() + + if (this%columns%size() > 0) then + call this%columns%push_back(SeparatorColumn(' ')) + w = w + 1 + end if + call this%columns%push_back(column) + + h0 = size(this%shared_header) + this%get_num_rows_separator() + h = column%get_num_rows_header() + this%num_rows_header = max(this%num_rows_header, h0 + h) + w = w + column%get_width() + call this%set_width(w) + + end subroutine add_column + + + recursive subroutine get_rows(this, node, rows) + class (MultiColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + character(:), allocatable, intent(out) :: rows(:) + + integer :: i, j + integer :: w0, w1 + class(TextColumn), pointer :: c + + integer :: total_width, height + character(:), allocatable :: column(:) + + total_width = this%get_width() + height = node%get_num_nodes() + + allocate(character(total_width) :: rows(height)) + + w0 = 1 + do i = 1, this%columns%size() + + c => this%columns%at(i) + w1 = w0 + c%get_width() - 1 + call c%get_rows(node, column) + + do j = 1, height + rows(j)(w0:w1) = column(j) + end do + + w0 = w1 + 1 + end do + + end subroutine get_rows + + + recursive subroutine get_header(this, header) + class (MultiColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + + integer :: i, column_width, column_height + integer :: w, w0, w1, h, h0, h1, h2 + integer :: total_width, total_height, shared_height + class(TextColumn), pointer :: c + character(:), allocatable :: column_header(:) + character(1) :: char + integer :: n_shared + + total_width = this%get_width() + total_height = this%num_rows_header + n_shared = size(this%shared_header) + shared_height = n_shared + this%get_num_rows_separator() + + allocate(character(total_width) :: header(total_height)) + + header(1:n_shared) = this%shared_header + call this%center(header(1:n_shared)) + call this%get_separator(header(n_shared+1), shared_height - n_shared) + + c => this%columns%at(1) + column_height = c%get_num_rows_header() + column_width = c%get_width() + header(shared_height+1:total_height-column_height) = repeat(' ', column_width) + call c%get_header(column_header) + do h = 1, column_height + h0 = total_height - column_height + h + header(h0) = column_header(h) + end do + deallocate(column_header) + + w0 = 1 + do i = 1, this%columns%size() + c => this%columns%at(i) + column_height = c%get_num_rows_header() + w = c%get_width() + w1 = w0 + w - 1 + h0 = shared_height + 1 + h1 = total_height-column_height+1 + h2 = total_height + + header(h0:h1-1)(w0:w1) = repeat(' ',w) + call c%get_header(column_header) + header(h1:h2)(w0:w1) = column_header + w0 = w1 + 1 ! space + deallocate(column_header) + end do + + end subroutine get_header + + integer function get_num_rows_header(this) result(num_rows) + class(MultiColumn), intent(in) :: this + num_rows = this%num_rows_header + end function get_num_rows_header + +end module MAPL_MultiColumn diff --git a/MAPL_Profiler/NameColumn.F90 b/MAPL_Profiler/NameColumn.F90 new file mode 100644 index 000000000000..2c73d0a5c7cd --- /dev/null +++ b/MAPL_Profiler/NameColumn.F90 @@ -0,0 +1,82 @@ +module MAPL_NameColumn + use MAPL_AbstractMeterNode + use MAPL_SimpleTextColumn + implicit none + private + + public :: NameColumn + + type, extends(SimpleTextColumn) :: NameColumn + private + character(:), allocatable :: indent + contains + procedure :: get_header + procedure :: get_num_rows_header + procedure :: get_row + end type NameColumn + + interface NameColumn + module procedure new_NameColumn + end interface NameColumn + + +contains + + + function new_NameColumn(width, indent, separator) result(column) + type (NameColumn) :: column + integer, intent(in) :: width + character(*), optional, intent(in) :: indent + character(1), optional, intent(in) :: separator + + call column%set_width(width) + if (present(indent)) then + column%indent = indent + else + column%indent = '--' + end if + + if (present(separator)) call column%set_separator(separator) + + end function new_NameColumn + + + subroutine get_header(this, header) + class (NameColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + + integer :: w, h + character(:), allocatable :: separator + + w = this%get_width() + h = this%get_num_rows_header() + + allocate(character(len=w) :: header(h)) + header(1) = 'Name' + if ( h <=1 ) return ! when separator is not in the constructor + call this%get_separator(header(2), h-1) + + end subroutine get_header + + + function get_row(this, node) result(row) + character(:), allocatable :: row + class (NameColumn), intent(in) :: this + class (AbstractMeterNode), intent(in) :: node + + integer :: n + + n = this%get_width() + allocate(character(len=n) :: row) + row(:) = repeat(this%indent, ncopies=node%get_depth()) // node%get_name() + + end function get_row + + + integer function get_num_rows_header(this) result(num_rows) + class(NameColumn), intent(in) :: this + num_rows = 1 + this%get_num_rows_separator() + end function get_num_rows_header + + +end module MAPL_NameColumn diff --git a/MAPL_Profiler/NumCyclesColumn.F90 b/MAPL_Profiler/NumCyclesColumn.F90 new file mode 100644 index 000000000000..720538b6b3ee --- /dev/null +++ b/MAPL_Profiler/NumCyclesColumn.F90 @@ -0,0 +1,41 @@ +module MAPL_NumCyclesColumn + use MAPL_AbstractColumn + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AdvancedMeter + use MAPL_AbstractMeter + implicit none + private + + public :: NumCyclesColumn + + type, extends(SimpleColumn) :: NumCyclesColumn + private + contains + procedure :: get_row + end type NumCyclesColumn + + +contains + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class(NumCyclesColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class (AbstractMeter), pointer :: tmr + + tmr => node%get_meter() + + select type (tmr) + class is (AdvancedMeter) + allocate(row, source=tmr%get_num_cycles()) +!!$ row = num_cycles + class default + print*,'error handling here' + end select + + end function get_row + + +end module MAPL_NumCyclesColumn diff --git a/MAPL_Profiler/PercentageColumn.F90 b/MAPL_Profiler/PercentageColumn.F90 new file mode 100644 index 000000000000..0c22d7cf2136 --- /dev/null +++ b/MAPL_Profiler/PercentageColumn.F90 @@ -0,0 +1,92 @@ +module MAPL_PercentageColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractMeterNode + use MAPL_AbstractColumn + implicit none + private + + public :: PercentageColumn + + type, extends(AbstractColumn) :: PercentageColumn + private + character(:), allocatable :: mode + class (AbstractColumn), allocatable :: reference_column + contains + procedure :: get_rows + procedure :: get_row + end type PercentageColumn + + interface PercentageColumn + module procedure new_PercentageColumn + end interface PercentageColumn + + +contains + + + function new_PercentageColumn(reference_column, mode) result(column) + type (PercentageColumn) :: column + class (AbstractColumn), intent(in) :: reference_column + character(*), optional, intent(in) :: mode + + column%reference_column = reference_column + if (present(mode)) then + column%mode = mode + else + column%mode = 'TOTAL' + end if + + end function new_PercentageColumn + + + function get_rows(this, node) result(rows) + use GFTL_UnlimitedVector + type (UnlimitedVector) :: rows + class (PercentageColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + type (UnlimitedVector) :: values + integer :: i + real(kind=REAL64) :: s, x + + values = this%reference_column%get_rows(node) + + s = 0 + do i = 1, values%size() + select type (v => values%at(i)) + type is (real(kind=REAL64)) + x = v + type is (integer) + x = v + end select + + select case (this%mode) + case ('TOTAL') + s = s + x + case ('MAX') + s = max(s, x) + end select + + end do + + do i = 1, values%size() + select type (v => values%at(i)) + type is (real(kind=REAL64)) + x = v + type is (integer) + x = v + end select + call rows%push_back(100*x/s) + end do + + end function get_rows + + ! Not used - PercentageColumn combines results across rows + function get_row(this, node) result(row) + class(*), allocatable :: row + class (PercentageColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + end function get_row + +end module MAPL_PercentageColumn diff --git a/MAPL_Profiler/ProfileReporter.F90 b/MAPL_Profiler/ProfileReporter.F90 new file mode 100644 index 000000000000..14ff532bab7e --- /dev/null +++ b/MAPL_Profiler/ProfileReporter.F90 @@ -0,0 +1,64 @@ +module MAPL_ProfileReporter + use MAPL_AbstractMeterNode + use MAPL_TextColumn + use MAPL_SeparatorColumn + use MAPL_TextColumnVector + use MAPL_MultiColumn + use MAPL_BaseProfiler + implicit none + private + + public :: ProfileReporter + + type, extends(MultiColumn) :: ProfileReporter + private + contains + procedure :: generate_report_profiler + generic :: generate_report => generate_report_profiler + end type ProfileReporter + + + interface ProfileReporter + module procedure :: new_ProfileReporter + end interface ProfileReporter + + +contains + + function new_ProfileReporter(header) result(reporter) + type(ProfileReporter) :: reporter + character(*), intent(in) :: header(:) + reporter%MultiColumn = MultiColumn(header) + end function new_ProfileReporter + + + function generate_report_profiler(this, p) result(report_lines) + character(:), allocatable :: report_lines(:) + class (ProfileReporter), target, intent(in) :: this + class (BaseProfiler), target, intent(in) :: p + + integer :: width, height + integer :: i + character(:), allocatable :: rows(:) + character(:), allocatable :: header(:) + class (AbstractMeterNode), pointer :: node + + call this%get_header(header) + node => p%get_root_node() + call this%get_rows(node, rows) + width = this%get_width() + height = size(header) + size(rows) + + allocate(character(len=width) :: report_lines(height)) + do i = 1, size(header) + report_lines(i) = header(i) + end do + do i = size(header)+1, height + report_lines(i) = rows(i - size(header)) + end do + + end function generate_report_profiler + + + +end module MAPL_ProfileReporter diff --git a/MAPL_Profiler/RssMemoryGauge.F90 b/MAPL_Profiler/RssMemoryGauge.F90 new file mode 100644 index 000000000000..aee14fc31196 --- /dev/null +++ b/MAPL_Profiler/RssMemoryGauge.F90 @@ -0,0 +1,81 @@ +#include "unused_dummy.H" + +module MAPL_RssMemoryGauge + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 + use MAPL_AbstractGauge + implicit none + private + + public :: RssMemoryGauge + + + type, extends(AbstractGauge) :: RssMemoryGauge + private + integer(kind=INT64) :: baseline = 0 + character(:), allocatable :: command + contains + procedure :: get_measurement + end type RssMemoryGauge + + interface RssMemoryGauge + module procedure :: new_RssMemoryGauge + end interface RssMemoryGauge + +#define PID_T kind(1) + + interface + function getpid() bind(c) + integer(kind=PID_T) :: getpid + end function getpid + end interface + +contains + + + function new_RssMemoryGauge() result(gauge) + type (RssMemoryGauge) :: gauge + + integer :: length + + call get_command_argument(0, length=length) + allocate(character(len=length) :: gauge%command) + call get_command_argument(0, value=gauge%command) + + end function new_RssMemoryGauge + + + function get_measurement(this) result(mem_use) + class (RssMemoryGauge), intent(inout) :: this + real(kind=REAL64) :: mem_use + + integer :: unit + integer(kind=INT64) :: MEM_UNITS = 1024 ! KB + character(:), allocatable :: tmp_file + + integer(kind=PID_T) :: pid + + character(16) :: buffer + character(:), allocatable :: pid_str + + _UNUSED_DUMMY(this) + pid = getpid() + write(buffer,'(i0)')pid + pid_str = trim(buffer) + tmp_file = 'tmp.pid'//pid_str + call execute_command_line("ps -p " // pid_str // " -ocommand='',rss='' | awk '{ print $NF }'> " // tmp_file) + + open(newunit=unit, file=tmp_file, form='formatted', access='sequential', status='old') + read(unit,*) mem_use + mem_use = mem_use * MEM_UNITS + close(unit, status='delete') + + + end function get_measurement + + +end module MAPL_RssMemoryGauge + + + + + diff --git a/MAPL_Profiler/SeparatorColumn.F90 b/MAPL_Profiler/SeparatorColumn.F90 new file mode 100644 index 000000000000..0b42a5fc65ae --- /dev/null +++ b/MAPL_Profiler/SeparatorColumn.F90 @@ -0,0 +1,70 @@ +module MAPL_SeparatorColumn + use MAPL_AbstractColumn + use MAPL_AbstractMeterNode + use Mapl_SimpleTextColumn + implicit none + private + + public :: SeparatorColumn + + type, extends(SimpleTextColumn) :: SeparatorColumn + private + character(:), allocatable :: field + contains + procedure :: get_header + procedure :: get_num_rows_header + procedure :: get_row + end type SeparatorColumn + + + interface SeparatorColumn + module procedure new_SeparatorColumn + end interface SeparatorColumn + + +contains + + + function new_SeparatorColumn(field) result(column) + type (SeparatorColumn) :: column + character(*), intent(in) :: field + + column%field = field + call column%set_width(len(field)) + + end function new_SeparatorColumn + + + subroutine get_header(this, header) + class (SeparatorColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + + header = [this%field] + + end subroutine get_header + + + function get_row(this, node) result(row) + character(:), allocatable :: row + class (SeparatorColumn), intent(in) :: this + class (AbstractMeterNode), intent(in) :: node + + integer :: n + + if (.false.) print*,shape(node) ! intentionally unused dummy + + n = this%get_width() + + allocate(character(n) :: row) + row = this%field + + end function get_row + + + integer function get_num_rows_header(this) result(num_rows) + class(SeparatorColumn), intent(in) :: this + num_rows = 1 + end function get_num_rows_header + +end module MAPL_SeparatorColumn + diff --git a/MAPL_Profiler/SimpleColumn.F90 b/MAPL_Profiler/SimpleColumn.F90 new file mode 100644 index 000000000000..ec1c4966a3b4 --- /dev/null +++ b/MAPL_Profiler/SimpleColumn.F90 @@ -0,0 +1,61 @@ +module MAPL_SimpleColumn + use MAPL_AbstractColumn + use GFTL_UnlimitedVector + use MAPL_AbstractMeterNode + use MAPL_DistributedMeter + implicit none + private + + public :: SimpleColumn + + type, abstract, extends(AbstractColumn) :: SimpleColumn + private + contains + procedure :: get_rows + procedure(i_get_row), deferred :: get_row + end type SimpleColumn + + + abstract interface + + function i_get_row(this, node) result(row) + import SimpleColumn + import AbstractMeterNode + ! Some columns return reals, others return integers + class(*), allocatable :: row + class(SimpleColumn), intent(in) :: this + class(AbstractMeterNode), target, intent(in) :: node + + end function i_get_row + + end interface + + +contains + + + function get_rows(this, node) result(rows) + type (UnlimitedVector) :: rows + class (SimpleColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + integer :: n_meters + integer :: i + class (AbstractMeterNodeIterator), allocatable :: iter + class (AbstractMeterNode), pointer :: subnode + + n_meters = node%get_num_nodes() + + iter = node%begin() + i = 0 + do while (iter /= node%end()) + i = i + 1 + subnode => iter%get() + call rows%push_back(this%get_row(subnode)) + call iter%next() + end do + + end function get_rows + + +end module MAPL_SimpleColumn diff --git a/MAPL_Profiler/SimpleTextColumn.F90 b/MAPL_Profiler/SimpleTextColumn.F90 new file mode 100644 index 000000000000..b4780a0ff92d --- /dev/null +++ b/MAPL_Profiler/SimpleTextColumn.F90 @@ -0,0 +1,84 @@ +module MAPL_SimpleTextColumn + use MAPL_TextColumn + use MAPL_AbstractMeterNode + implicit none + private + + public :: SimpleTextColumn + + type, abstract, extends(TextColumn) :: SimpleTextColumn + private + contains + procedure :: get_rows_range + procedure :: get_rows + procedure(i_get_row), deferred :: get_row + end type SimpleTextColumn + + abstract interface + + function i_get_row(this, node) result(row) + use MAPL_AbstractMeterNode + import SimpleTextColumn + character(:), allocatable :: row + class (SimpleTextColumn), intent(in) :: this + class (AbstractMeterNode), intent(in) :: node + end function i_get_row + + end interface + + +contains + + + ! Using subroutines instead of functions as a workaround for gfortran 8.2 + ! Reproducer being submitted by Damian Rouson (10/12/2018) + subroutine get_rows_range(this, begin, end, rows) + class (SimpleTextColumn), target, intent(in) :: this + class (AbstractMeterNodeIterator), intent(in) :: begin + class (AbstractMeterNodeIterator), intent(in) :: end + character(:), allocatable, intent(inout) :: rows(:) + + class (AbstractMeterNodeIterator), allocatable :: iter + integer :: i + integer :: width + class (AbstractMeterNode), pointer :: subnode + + ! count_nodes + iter = begin + i = 0 + do while (iter /= end) + i = i + 1 + call iter%next() + end do + + width = this%get_width() + allocate(character(width) :: rows(i)) + + ! Fill rows + iter = begin + i = 0 + do while (iter /= end) + i = i + 1 + subnode => iter%get() + rows(i) = this%get_row(subnode) + call iter%next() + end do + + end subroutine get_rows_range + + + subroutine get_rows(this, node, rows) + class (SimpleTextColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + character(:), allocatable, intent(out) :: rows(:) + + class (AbstractMeterNodeIterator), allocatable :: b, e + + b = node%begin() + e = node%end() + + call this%get_rows_range(b, e, rows) + + end subroutine get_rows + +end module MAPL_SimpleTextColumn diff --git a/MAPL_Profiler/StdDevColumn.F90 b/MAPL_Profiler/StdDevColumn.F90 new file mode 100644 index 000000000000..8954cb13a247 --- /dev/null +++ b/MAPL_Profiler/StdDevColumn.F90 @@ -0,0 +1,91 @@ +module MAPL_StdDevColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_AbstractColumn + use MAPL_SimpleColumn + use MAPL_AbstractMeterNode + use MAPL_AbstractMeter + use MAPL_AdvancedMeter + use Mapl_DistributedMeter + implicit none + private + + public :: StdDevColumn + + type, extends(SimpleColumn) :: StdDevColumn + private + logical :: relative = .false. + character(:), allocatable :: option + contains + procedure :: get_row + procedure :: get_row_dist + end type StdDevColumn + + interface StdDevColumn + module procedure :: new_StdDevColumn + end interface StdDevColumn + + +contains + + + function new_StdDevColumn(relative, option) result(column) + type(StdDevColumn) :: column + logical, optional, intent(in) :: relative + character(*), optional, intent(in) :: option + + if (present(relative)) column%relative = relative + if (present(option)) column%option = option + + end function new_StdDevColumn + + + function get_row(this, node) result(row) + class(*), allocatable :: row + class (StdDevColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + + class (AbstractMeter), pointer :: tmr + + + if (.not. allocated(this%option)) then + tmr => node%get_meter() + select type (tmr) + class is (AdvancedMeter) + if (this%relative) then + allocate(row, source=tmr%get_relative_deviation()) + else + allocate(row, source=tmr%get_standard_deviation()) + end if + class default + print*,'error handling here' + end select + else + call this%get_row_dist(node, row) + end if + + end function get_row + + + subroutine get_row_dist(this, node, row) + class (StdDevColumn), target, intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + class(*), allocatable, intent(out) :: row + + class(AbstractMeter), pointer :: m + type(DistributedStatistics) :: stats + type(DistributedReal64) :: std_deviation + + m => node%get_meter() + + select type (m) + class is (DistributedMeter) + stats = m%get_statistics() + std_deviation = stats%sum_square_deviation + print*,__FILE__,__LINE__,'std deviation not fully implemented' + call this%fill_row(std_deviation, this%option, row) + end select + end subroutine get_row_dist + +end module MAPL_StdDevColumn + + diff --git a/MAPL_Profiler/TextColumn.F90 b/MAPL_Profiler/TextColumn.F90 new file mode 100644 index 000000000000..a96a3f5ec73b --- /dev/null +++ b/MAPL_Profiler/TextColumn.F90 @@ -0,0 +1,132 @@ +module MAPL_TextColumn + use MAPL_AbstractMeterNode + implicit none + private + + public :: TextColumn + + type, abstract :: TextColumn + private + integer :: column_width = 0 + character(:), allocatable :: separator + contains + procedure :: set_width + procedure :: get_width + procedure(i_get_header), deferred :: get_header + procedure(i_get_num_rows_header), deferred :: get_num_rows_header + procedure(i_get_rows), deferred :: get_rows + procedure :: center + + procedure :: set_separator + procedure :: get_separator + procedure :: get_num_rows_separator + end type TextColumn + + abstract interface + + subroutine i_get_header(this, header) + import TextColumn + class (TextColumn), intent(in) :: this + character(:), allocatable, intent(out) :: header(:) + end subroutine i_get_header + + subroutine i_get_rows(this, node, rows) + use MAPL_AbstractMeterNode + import TextColumn + class (TextColumn), intent(in) :: this + class (AbstractMeterNode), target, intent(in) :: node + character(:), allocatable, intent(out) :: rows(:) + end subroutine i_get_rows + + integer function i_get_num_rows_header(this) result(num_rows) + import TextColumn + class (TextColumn), intent(in) :: this + end function i_get_num_rows_header + + end interface + + +contains + + + subroutine set_width(this, column_width) + class (TextColumn), intent(inout) :: this + integer, intent(in) :: column_width + + this%column_width = column_width + + end subroutine set_width + + + integer function get_width(this) result(column_width) + class (TextColumn), intent(in) :: this + column_width = this%column_width + end function get_width + + + subroutine center(this, rows, space) + class (TextColumn), intent(in) :: this + character(*), intent(inout) :: rows(:) + character(1), optional, intent(in) :: space + + integer :: w, i + integer :: n, n_0, n_1 + character(:), allocatable :: tmp + character(1) :: space_ + + if (present(space)) then + space_ = space + else + space_ = ' ' + end if + + w = this%get_width() + do i = 1, size(rows) + tmp = trim(adjustl(rows(i))) + n = len(tmp) + n_0 = (w - n)/2 + n_1 = w - (n + n_0) + rows(i)(:) = repeat(space_,n_0) // tmp // repeat(space_, n_1) + end do + + + end subroutine center + + + subroutine set_separator(this, separator) + class(TextColumn), intent(inout) :: this + character(1), intent(in) :: separator + this%separator = separator + end subroutine set_separator + + ! Would be a function, but this is a workaround for gfortran 8.2 + ! issue with allocatable arrays of deferred length strings. + subroutine get_separator(this, separator, k) + class(TextColumn), intent(in) :: this + integer, intent(in) :: k + character(*), intent(inout) :: separator(k) + + integer :: w + character(1) :: c + + w = this%get_width() + if (allocated(this%separator)) then + c = this%separator + separator(1) = repeat(c, w) + end if + + end subroutine get_separator + + + integer function get_num_rows_separator(this) result(num_rows) + class (TextColumn), intent(in) :: this + + if (allocated(this%separator)) then + num_rows = 1 + else + num_rows = 0 + end if + + end function get_num_rows_separator + +end module MAPL_TextColumn diff --git a/MAPL_Profiler/TextColumnVector.F90 b/MAPL_Profiler/TextColumnVector.F90 new file mode 100644 index 000000000000..18502a0966b0 --- /dev/null +++ b/MAPL_Profiler/TextColumnVector.F90 @@ -0,0 +1,10 @@ +module MAPL_TextColumnVector + use MAPL_TextColumn + +#define _type class(TextColumn) +#define _allocatable +#define _vector TextColumnVector +#define _iterator TextColumnVectorIterator +#include "templates/vector.inc" + +end module MAPL_TextColumnVector diff --git a/MAPL_Profiler/TimeProfiler.F90 b/MAPL_Profiler/TimeProfiler.F90 new file mode 100644 index 000000000000..14d5d71b67dc --- /dev/null +++ b/MAPL_Profiler/TimeProfiler.F90 @@ -0,0 +1,136 @@ +module MAPL_TimeProfiler_private + use MAPL_BaseProfiler, only: BaseProfiler + use MAPL_BaseProfiler, only: TimeProfilerIterator => BaseProfilerIterator + + use MAPL_MpiTimerGauge + use MAPL_AdvancedMeter + use MAPL_AbstractMeter + use MAPL_MeterNode + implicit none + private + + public :: TimeProfiler + public :: TimeProfilerIterator + public :: get_global_time_profiler + + type, extends(BaseProfiler) :: TimeProfiler + private + contains + procedure :: make_meter + procedure :: copy + end type TimeProfiler + + interface TimeProfiler + module procedure new_TimeProfiler + end interface TimeProfiler + + type(TimeProfiler), protected, target :: global_time_profiler + +contains + + + function new_TimeProfiler(name, comm_world) result(prof) + type(TimeProfiler), target :: prof + character(*), intent(in) :: name + integer, optional,intent(in) :: comm_world + + call prof%set_comm_world(comm_world = comm_world) + call prof%set_node(MeterNode(name, prof%make_meter())) + + end function new_TimeProfiler + + function make_meter(this) result(meter) + class(AbstractMeter), allocatable :: meter + class(TimeProfiler), intent(in) :: this + meter = AdvancedMeter(MpiTimerGauge()) + end function make_meter + + + function get_global_time_profiler() result(time_profiler) + type(TimeProfiler), pointer :: time_profiler + + time_profiler => global_time_profiler + + end function get_global_time_profiler + + + subroutine copy(new, old) + class(TimeProfiler), target, intent(inout) :: new + class(BaseProfiler), target, intent(in) :: old + + call new%copy_profiler(old) + + end subroutine copy + + +end module MAPL_TimeProfiler_Private + + + +module MAPL_TimeProfiler + use MAPL_BaseProfiler + use MAPL_TimeProfiler_private + implicit none + private + + public :: TimeProfiler + public :: TimeProfilerIterator + public :: get_global_time_profiler + public :: initialize + public :: finalize + public :: start + public :: stop + +contains + + subroutine initialize(name) + character(*), optional, intent(in) :: name + + type(TimeProfiler), pointer :: time_profiler + character(:), allocatable :: name_ + + if (present(name)) then + name_ = name + else + name_ = 'top' + end if + + time_profiler => get_global_time_profiler() + time_profiler = TimeProfiler(name_) + + end subroutine initialize + + + subroutine finalize() + + type(TimeProfiler), pointer :: time_profiler + + time_profiler => get_global_time_profiler() + call time_profiler%finalize() + + end subroutine finalize + + + subroutine start(name) + character(*), intent(in) :: name + + type(TimeProfiler), pointer :: time_profiler + + time_profiler => get_global_time_profiler() + call time_profiler%start(name) + + end subroutine start + + + subroutine stop(name) + character(*), intent(in) :: name + + type(TimeProfiler), pointer :: time_profiler + + time_profiler => get_global_time_profiler() + call time_profiler%stop(name) + + end subroutine stop + + +end module MAPL_TimeProfiler diff --git a/MAPL_Profiler/VmstatMemoryGauge.F90 b/MAPL_Profiler/VmstatMemoryGauge.F90 new file mode 100644 index 000000000000..b54ec3dac92b --- /dev/null +++ b/MAPL_Profiler/VmstatMemoryGauge.F90 @@ -0,0 +1,67 @@ +module MAPL_VmstatMemoryGauge + use, intrinsic :: iso_fortran_env, only: REAL64, INT64 + use MAPL_AbstractGauge + implicit none + private + + public :: VmstatMemoryGauge + + + type, extends(AbstractGauge) :: VmstatMemoryGauge + private + integer(kind=INT64) :: baseline = 0 + contains + procedure :: get_measurement + end type VmstatMemoryGauge + + interface VmstatMemoryGauge + module procedure :: new_VmstatMemoryGauge + end interface VmstatMemoryGauge + + +contains + + + function new_VmstatMemoryGauge() result(gauge) + type (VmstatMemoryGauge) :: gauge + + end function new_VmstatMemoryGauge + + + function get_measurement(this) result(mem_use) + class (VmstatMemoryGauge), intent(inout) :: this + real(kind=REAL64) :: mem_use + + integer :: unit + integer(kind=INT64) :: MEM_UNITS = 4096 ! page size is 4096 bytes + character(:), allocatable :: tmp_file + block + use MPI + integer :: rank, ierror + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror) + allocate(character(4) :: tmp_file) + write(tmp_file,'(i4.4)')rank + tmp_file = 'tmp_' // tmp_file // '.dat' + if (rank == 0) then + call execute_command_line("vm_stat | grep free | awk '{ print $3 }'> " // tmp_file) + + open(newunit=unit, file=tmp_file, form='formatted', access='sequential', status='old') + read(unit,*) mem_use + mem_use = - mem_use * MEM_UNITS ! mem free is negative memory used + close(unit, status='delete') + else + mem_use = 0 + end if + end block + + + + end function get_measurement + + +end module MAPL_VmstatMemoryGauge + + + + + diff --git a/MAPL_Profiler/demo/CMakeLists.txt b/MAPL_Profiler/demo/CMakeLists.txt new file mode 100644 index 000000000000..290d3a674f34 --- /dev/null +++ b/MAPL_Profiler/demo/CMakeLists.txt @@ -0,0 +1,7 @@ +add_executable(demo.x demo.F90) +target_link_libraries(demo.x MAPL_Profiler) + +add_executable(mpi_demo.x mpi_demo.F90) +target_link_libraries(mpi_demo.x MAPL_Profiler ${MPI_Fortran_LIBRARIES}) +target_include_directories (mpi_demo.x PUBLIC ${MPI_Fortran_INCLUDE_DIRS}) +target_include_directories (mpi_demo.x PUBLIC ${CMAKE_BINARY_DIR}/src) diff --git a/MAPL_Profiler/demo/demo.F90 b/MAPL_Profiler/demo/demo.F90 new file mode 100644 index 000000000000..3ea422c138c4 --- /dev/null +++ b/MAPL_Profiler/demo/demo.F90 @@ -0,0 +1,135 @@ +program main + use MPI + use MAPL_Profiler + implicit none + + + !type (MemoryProfiler), target :: mem_prof + type (TimeProfiler), target :: main_prof + type (TimeProfiler), target :: lap_prof + type (ProfileReporter) :: reporter + !type (ProfileReporter) :: mem_reporter + + character(:), allocatable :: report_lines(:) + integer :: i + integer :: ierror + + call MPI_Init(ierror) + main_prof = TimeProfiler('TOTAL') ! timer 1 + call main_prof%start() + lap_prof = TimeProfiler('Lap') + call lap_prof%start() + !mem_prof = MemoryProfiler('TOTAL') + + call main_prof%start('init reporter') + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn())) + call reporter%add_column(FormattedTextColumn(' T(inc)','(f9.6)', 9, InclusiveColumn())) + call reporter%add_column(FormattedTextColumn(' T(exc)','(f9.6)', 9, ExclusiveColumn())) + call reporter%add_column(FormattedTextColumn('%(inc)','(f6.2)', 6, PercentageColumn(InclusiveColumn()))) + call reporter%add_column(FormattedTextColumn('%(exc)','(f6.2)', 6, PercentageColumn(ExclusiveColumn()))) + call reporter%add_column(FormattedTextColumn(' std. dev ','(f12.4)', 12, StdDevColumn())) + call reporter%add_column(FormattedTextColumn(' rel. dev ','(f12.4)', 12, StdDevColumn(relative=.true.))) + call reporter%add_column(FormattedTextColumn(' max cyc ','(f12.8)', 12, MaxCycleColumn())) + call reporter%add_column(FormattedTextColumn(' min cyc ','(f12.8)', 12, MinCycleColumn())) + call reporter%add_column(FormattedTextColumn(' mean cyc','(f12.8)', 12, MeanCycleColumn())) + + !call mem_reporter%add_column(NameColumn(20)) + !call mem_reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn())) + !call mem_reporter%add_column(MemoryTextColumn(' RSS ','(i4,1x,a2)', 7, InclusiveColumn())) + !call mem_reporter%add_column(MemoryTextColumn('Cyc RSS','(i4,1x,a2)', 7, MeanCycleColumn())) + + call main_prof%stop('init reporter') + + + !call mem_prof%start('lap') + call do_lap(lap_prof) ! lap 1 + call lap_prof%stop() + call main_prof%accumulate(lap_prof) + !call mem_prof%stop('lap') + + + call main_prof%start('use reporter') + report_lines = reporter%generate_report(lap_prof) + write(*,'(a)')'Lap 1' + write(*,'(a)')'=====' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)')'' + call main_prof%stop('use reporter') + + !call mem_prof%start('lap') + call lap_prof%reset() + call do_lap(lap_prof) ! lap 2 + call lap_prof%stop() + call main_prof%accumulate(lap_prof) + call main_prof%start('use reporter') + report_lines = reporter%generate_report(lap_prof) + write(*,'(a)')'Lap 2' + write(*,'(a)')'=====' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + call main_prof%stop('use reporter') + !call mem_prof%stop('lap') + + call main_prof%stop() + report_lines = reporter%generate_report(main_prof) + write(*,'(a)')'Final profile' + write(*,'(a)')'=============' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + + + call MPI_Finalize(ierror) + + !call mem_prof%finalize() + !report_lines = mem_reporter%generate_report(mem_prof) + !write(*,'(a)')'Memory profile' + !write(*,'(a)')'==============' + !do i = 1, size(report_lines) + ! write(*,'(a)') report_lines(i) + !end do + !write(*,'(a)') '' + +contains + + subroutine do_lap(prof) + type (TimeProfiler), target :: prof + + real, pointer :: x(:) + + allocate(x(10**7)) + call random_number(x) + print*,sum(x) + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%start('timer_1b') ! 4 + call prof%start('timer_1b1') ! 5 + call prof%stop('timer_1b1') + call prof%stop('timer_1b') + call prof%stop('timer_1') + call prof%start('timer_2') ! 6 + call prof%start('timer_2b')! 7 + call prof%stop('timer_2b') + call prof%stop('timer_2') + + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%stop('timer_1') + + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + end subroutine do_lap + + +end program main + diff --git a/MAPL_Profiler/demo/mpi_demo.F90 b/MAPL_Profiler/demo/mpi_demo.F90 new file mode 100644 index 000000000000..d99dba2085d4 --- /dev/null +++ b/MAPL_Profiler/demo/mpi_demo.F90 @@ -0,0 +1,182 @@ +program main + use MAPL_Profiler + use MPI + implicit none + + + type (MemoryProfiler), target :: mem_prof + type (DistributedProfiler), target :: main_prof + type (DistributedProfiler), target :: lap_prof + type (ProfileReporter) :: reporter, main_reporter + type (ProfileReporter) :: mem_reporter + + character(:), allocatable :: report_lines(:) + integer :: i + integer :: rank, ierror + +!!$ mem_prof = MemoryProfiler('TOTAL') + + call MPI_Init(ierror) + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror) + + main_prof = DistributedProfiler('TOTAL', MpiTimerGauge(), MPI_COMM_WORLD) ! timer 1 + lap_prof = DistributedProfiler('Lap', MpiTimerGauge(), MPI_COMM_WORLD) + + call main_prof%start('init reporter') + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn())) + call reporter%add_column(FormattedTextColumn(' T(inc)','(f9.6)', 9, InclusiveColumn())) + call reporter%add_column(FormattedTextColumn(' T(exc)','(f9.6)', 9, ExclusiveColumn())) + call reporter%add_column(FormattedTextColumn('%(inc)','(f6.2)', 6, PercentageColumn(InclusiveColumn()))) + call reporter%add_column(FormattedTextColumn('%(exc)','(f6.2)', 6, PercentageColumn(ExclusiveColumn()))) + call reporter%add_column(FormattedTextColumn(' std. dev ','(f12.4)', 12, StdDevColumn())) + call reporter%add_column(FormattedTextColumn(' rel. dev ','(f12.4)', 12, StdDevColumn(relative=.true.))) + call reporter%add_column(FormattedTextColumn(' max cyc ','(f12.8)', 12, MaxCycleColumn())) + call reporter%add_column(FormattedTextColumn(' min cyc ','(f12.8)', 12, MinCycleColumn())) + call reporter%add_column(FormattedTextColumn(' mean cyc','(f12.8)', 12, MeanCycleColumn())) + + call main_reporter%add_column(NameColumn(20)) + call main_reporter%add_column(FormattedTextColumn('Inclusive','(f9.6)', 9, InclusiveColumn('MEAN'))) + call main_reporter%add_column(FormattedTextColumn('% Incl','(f6.2)', 6, PercentageColumn(InclusiveColumn('MEAN'),'MAX'))) + call main_reporter%add_column(FormattedTextColumn('Exclusive','(f9.6)', 9, ExclusiveColumn('MEAN'))) + call main_reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) + call main_reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) + call main_reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) + call main_reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) + call main_reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) + + call mem_reporter%add_column(NameColumn(20)) + call mem_reporter%add_column(FormattedTextColumn('#-cycles','(i5.0)', 5, NumCyclesColumn())) + !call mem_reporter%add_column(MemoryTextColumn(' RSS ','(i4,1x,a2)', 7, InclusiveColumn())) + !call mem_reporter%add_column(MemoryTextColumn('Cyc RSS','(i4,1x,a2)', 7, MeanCycleColumn())) + + call main_prof%stop('init reporter') + + +!!$ call mem_prof%start('lap') + call do_lap(lap_prof) ! lap 1 + call lap_prof%finalize() + call main_prof%accumulate(lap_prof) +!!$ call mem_prof%stop('lap') + + + call main_prof%start('use reporter') + if (rank == 0) then + report_lines = reporter%generate_report(lap_prof) + write(*,'(a)')'Lap 1' + write(*,'(a)')'=====' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)')'' + end if + call main_prof%stop('use reporter') + +!!$ call mem_prof%start('lap') + call lap_prof%reset() + call do_lap(lap_prof) ! lap 2 + call lap_prof%finalize() + call main_prof%accumulate(lap_prof) + call main_prof%start('use reporter') + + if (rank == 0) then + report_lines = reporter%generate_report(lap_prof) + write(*,'(a)')'Lap 2' + write(*,'(a)')'=====' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + + call main_prof%stop('use reporter') +!!$ call mem_prof%stop('lap') + + call main_prof%finalize() + call main_prof%reduce() + report_lines = reporter%generate_report(main_prof) + if (rank == 0) then + write(*,'(a)')'Final profile(0)' + write(*,'(a)')'=============' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + call MPI_Barrier(MPI_COMM_WORLD, ierror) + if (rank == 1) then + write(*,'(a)')'Final profile (1)' + write(*,'(a)')'================' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + call MPI_Barrier(MPI_COMM_WORLD, ierror) + + report_lines = main_reporter%generate_report(main_prof) + if (rank == 0) then + write(*,'(a)')'Parallel profile' + write(*,'(a)')'================' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + +!!$ call mem_prof%finalize() +!!$ if (rank == 0) then +!!$ report_lines = mem_reporter%generate_report(mem_prof) +!!$ write(*,'(a)')'Memory profile' +!!$ write(*,'(a)')'==============' +!!$ do i = 1, size(report_lines) +!!$ write(*,'(a)') report_lines(i) +!!$ end do +!!$ write(*,'(a)') '' +!!$ end if + + call MPI_Finalize(ierror) + +contains + + subroutine do_lap(prof) + type (DistributedProfiler), target :: prof + + real, pointer :: x(:) + + call prof%start('timer_1') ! 2 + allocate(x(10**7 * rank)) + call random_number(x) + print*,sum(x) + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%start('timer_1b') ! 4 + call prof%start('timer_1b1') ! 5 + call prof%stop('timer_1b1') + call prof%stop('timer_1b') + call prof%stop('timer_1') + call prof%start('timer_2') ! 6 + call prof%start('timer_2b')! 7 + call prof%stop('timer_2b') + call prof%stop('timer_2') + + call prof%start('timer_1') ! 2 + block + real, allocatable :: x(:) + allocate(x(1000000)) + call random_number(x) + print*,'sum: ', sum(exp(x)) + deallocate(x) + end block + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%stop('timer_1') + + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + end subroutine do_lap + +end program main + diff --git a/MAPL_Profiler/tests/CMakeLists.txt b/MAPL_Profiler/tests/CMakeLists.txt new file mode 100644 index 000000000000..56b29f74788c --- /dev/null +++ b/MAPL_Profiler/tests/CMakeLists.txt @@ -0,0 +1,23 @@ +set (TEST_SRCS + test_AdvancedMeter.pf + test_NameColumn.pf + test_ExclusiveColumn.pf + test_PercentageColumn.pf + test_TimeProfiler.pf + test_ProfileReporter.pf + test_MeterNode.pf + test_MeterNodeIterator.pf + test_DistributedMeter.pf + ) + + +add_pfunit_ctest ( + MAPL_Profiler_tests + TEST_SOURCES ${TEST_SRCS} + LINK_LIBRARIES MAPL_Profiler + MAX_PES 8 + ) + + +add_dependencies (tests MAPL_Profiler_tests) + diff --git a/MAPL_Profiler/tests/test_AdvancedMeter.pf b/MAPL_Profiler/tests/test_AdvancedMeter.pf new file mode 100644 index 000000000000..348f0fdcad30 --- /dev/null +++ b/MAPL_Profiler/tests/test_AdvancedMeter.pf @@ -0,0 +1,203 @@ +module test_AdvancedMeter + use, intrinsic :: iso_fortran_env, only: REAL64 + use funit + use MAPL_Profiler + implicit none + +contains + + + @test + subroutine test_is_active() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + + ! Initial state is + @assertFalse(t%is_active()) + + call t%start() + @assertTrue(t%is_active()) + + call t%stop() + @assertFalse(t%is_active()) + + end subroutine test_is_active + + + @test + subroutine test_fail_on_double_start() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + + @assertEqual(MAPL_METER_IS_VALID, t%get_status()) + call t%start() + @assertEqual(MAPL_METER_IS_VALID, t%get_status()) + call t%start() + @assertEqual(MAPL_METER_START_ACTIVE, t%get_status()) + + end subroutine test_fail_on_double_start + + + @test + subroutine test_fail_on_double_stop() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%stop() + @assertEqual(MAPL_METER_STOP_INACTIVE, t%get_status()) + + end subroutine test_fail_on_double_stop + + + @test + subroutine test_get_num_cycles() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + @assertEqual(0, t%get_num_cycles()) + call t%start() + @assertEqual(0, t%get_num_cycles()) + call t%stop() + @assertEqual(1, t%get_num_cycles()) + call t%start() + @assertEqual(1, t%get_num_cycles()) + call t%stop() + @assertEqual(2, t%get_num_cycles()) + + end subroutine test_get_num_cycles + + + @test + subroutine test_add_cycle() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%add_cycle(increment=1.0_REAL64) + @assertEqual(1.0, t%get_total()) + call t%add_cycle(increment=2.0_REAL64) + @assertEqual(3.0, t%get_total()) + + @assertEqual(2, t%get_num_cycles()) + @assertFalse(t%is_active()) + + end subroutine test_add_cycle + + @test + subroutine test_reset() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%start() + call t%add_cycle(increment=1._REAL64) + call t%reset() + + @assertEqual(0, t%get_num_cycles()) + @assertFalse(t%is_active()) + @assertEqual(0, t%get_total()) + + end subroutine test_reset + + + @test + subroutine test_get_min_cycle() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%add_cycle(increment=1._REAL64) + call t%add_cycle(increment=3._REAL64) + @assertEqual(1., t%get_min_cycle()) + + call t%reset() + call t%add_cycle(increment=2._REAL64) + call t%add_cycle(increment=4._REAL64) + @assertEqual(2., t%get_min_cycle()) + + end subroutine test_get_min_cycle + + @test + subroutine test_get_max_cycle() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%add_cycle(increment=2._REAL64) + call t%add_cycle(increment=4._REAL64) + @assertEqual(4., t%get_max_cycle()) + + call t%reset() + call t%add_cycle(increment=1._REAL64) + call t%add_cycle(increment=3._REAL64) + @assertEqual(3., t%get_max_cycle()) + + end subroutine test_get_max_cycle + + + @test + subroutine test_get_mean_cycle() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%add_cycle(increment=1._REAL64) + call t%add_cycle(increment=3._REAL64) + @assertEqual(2., t%get_mean_cycle()) + + call t%reset() + call t%add_cycle(increment=3._REAL64) + call t%add_cycle(increment=5._REAL64) + @assertEqual(4., t%get_mean_cycle()) + + end subroutine test_get_mean_cycle + + + @test + subroutine test_get_standard_deviation() + type (AdvancedMeter) :: t + + t = AdvancedMeter(MpiTimerGauge()) + call t%add_cycle(increment=1._REAL64) + call t%add_cycle(increment=3._REAL64) + @assertEqual(1., t%get_standard_deviation()) + + call t%reset() + call t%add_cycle(increment=1._REAL64) + call t%add_cycle(increment=3._REAL64) + @assertEqual(1., t%get_standard_deviation()) + + call t%reset() + call t%add_cycle(increment=7._REAL64 - 2) + call t%add_cycle(increment=7._REAL64 - 1) + call t%add_cycle(increment=7._REAL64 + 3) + + @assertEqual(sqrt(14._REAL64/3), t%get_standard_deviation()) + + end subroutine test_get_standard_deviation + + + subroutine test_accumulate() + type (AdvancedMeter) :: t, lap + + t = AdvancedMeter(MpiTimerGauge()) + lap = t + + call lap%add_cycle(increment=1._REAL64) + call lap%add_cycle(increment=3._REAL64) + + ! Copy lap and verify state is as expected + t = lap + call lap%reset() + @assertEqual(4., t%get_total()) + @assertEqual(1., t%get_standard_deviation()) + + ! Use lap again and accumulate + call lap%add_cycle(increment=2._REAL64) + call lap%add_cycle(increment=4._REAL64) + + call t%accumulate(lap) + @assertEqual(9., t%get_total()) + @assertEqual(4, t%get_num_cycles()) + + end subroutine test_accumulate + + +end module test_AdvancedMeter diff --git a/MAPL_Profiler/tests/test_Column.pf b/MAPL_Profiler/tests/test_Column.pf new file mode 100644 index 000000000000..e7f948e0d7db --- /dev/null +++ b/MAPL_Profiler/tests/test_Column.pf @@ -0,0 +1,27 @@ +module test_Column + use MAPL_Profiler + use funit + +contains + + + subroutine test_one_timer() + type (ExclusiveTimeColumn) :: column + type (TimerTree), target :: tree + type (TimerReport) :: report + type (AbstractTimer) :: t + + tree = TimerTree('all') + t => tree%get_timer() + call t%add_cycle(1.0) + + column = ExclusiveTimeColumn(format='(f7.2)') + report = column%report(tree) + + @assertEqual(' exc ',report%get_header()) + @assertEqual(' 1.00',report%get_row(1)) + + end subroutine test_one_timer + + +end module test_Column diff --git a/MAPL_Profiler/tests/test_DistributedMeter.pf b/MAPL_Profiler/tests/test_DistributedMeter.pf new file mode 100644 index 000000000000..b5bb9138452f --- /dev/null +++ b/MAPL_Profiler/tests/test_DistributedMeter.pf @@ -0,0 +1,162 @@ +module test_DistributedMeter + use, intrinsic :: iso_fortran_env, only: REAL64 + use pfunit + use MAPL_Profiler + implicit none + +contains + + + @test(npes=[1]) + subroutine test_trivial(this) + class (MpiTestMethod), intent(inout) :: this + + type (DistributedMeter) :: distributed + type (DistributedReal64) :: distributed_total + + + distributed = DistributedMeter(MpiTimerGauge()) + call distributed%add_cycle(1.0_REAL64) + call distributed%reduce(this%getMpiCommunicator(), 0._REAL64) + + distributed_total = distributed%get_stats_total() + @assertEqual(1.0, distributed_total%total) + @assertEqual(1.0, distributed_total%min) + @assertEqual(1.0, distributed_total%max) + + @assertEqual(0, distributed_total%min_pe) + @assertEqual(0, distributed_total%max_pe) + @assertEqual(1, distributed_total%num_pes) + + end subroutine test_trivial + + + @test(npes=[2]) + subroutine test_get_total(this) + class (MpiTestMethod), intent(inout) :: this + + type (DistributedMeter) :: distributed + type (DistributedReal64) :: distributed_total + + distributed = DistributedMeter(MpiTimerGauge()) + select case (this%getProcessRank()) + case (0) + call distributed%add_cycle(1.0_REAL64) + call distributed%add_cycle(3.0_REAL64) + case (1) + call distributed%add_cycle(2.0_REAL64) + end select + call distributed%reduce(this%getMpiCommunicator(), 0._REAL64) + + distributed_total = distributed%get_stats_total() + + if (this%getProcessRank() == 0) then + @assertEqual(6.0, distributed_total%total) + @assertEqual(2.0, distributed_total%min) + @assertEqual(4.0, distributed_total%max) + + @assertEqual(1, distributed_total%min_pe) + @assertEqual(0, distributed_total%max_pe) + @assertEqual(2, distributed_total%num_pes) + end if + + end subroutine test_get_total + + @test(npes=[2]) + subroutine test_get_min(this) + class (MpiTestMethod), intent(inout) :: this + + type (DistributedMeter) :: distributed + type (DistributedReal64) :: distributed_min_cycle + + distributed = DistributedMeter(MpiTimerGauge()) + select case (this%getProcessRank()) + case (0) + call distributed%add_cycle(1.0_REAL64) + call distributed%add_cycle(3.0_REAL64) + case (1) + call distributed%add_cycle(2.0_REAL64) + end select + call distributed%reduce(this%getMpiCommunicator(), 0._REAL64) + + distributed_min_cycle = distributed%get_stats_min_cycle() + + if (this%getProcessRank() == 0) then + ! Some of these are meaningless/pointless + @assertEqual(3.0, distributed_min_cycle%total) + @assertEqual(1.0, distributed_min_cycle%min) + @assertEqual(2.0, distributed_min_cycle%max) + + @assertEqual(0, distributed_min_cycle%min_pe) + @assertEqual(1, distributed_min_cycle%max_pe) + @assertEqual(2, distributed_min_cycle%num_pes) + end if + + end subroutine test_get_min + + @test(npes=[2]) + subroutine test_get_max(this) + class (MpiTestMethod), intent(inout) :: this + + type (DistributedMeter) :: distributed + type (DistributedReal64) :: distributed_max_cycle + + distributed = DistributedMeter(MpiTimerGauge()) + select case (this%getProcessRank()) + case (0) + call distributed%add_cycle(1.0_REAL64) + call distributed%add_cycle(3.0_REAL64) + case (1) + call distributed%add_cycle(2.0_REAL64) + end select + + call distributed%reduce(this%getMpiCommunicator(), 0._REAL64) + distributed_max_cycle = distributed%get_stats_max_cycle() + + if (this%getProcessRank() == 0) then + ! Some of these are meaningless/pointless + @assertEqual(5.0, distributed_max_cycle%total) + @assertEqual(2.0, distributed_max_cycle%min) + @assertEqual(3.0, distributed_max_cycle%max) + + @assertEqual(1, distributed_max_cycle%min_pe) + @assertEqual(0, distributed_max_cycle%max_pe) + @assertEqual(2, distributed_max_cycle%num_pes) + end if + + end subroutine test_get_max + + @test(npes=[2]) + subroutine test_get_num_cycles(this) + class (MpiTestMethod), intent(inout) :: this + + type (DistributedMeter) :: distributed + type (DistributedInteger) :: distributed_num_cycles + + + distributed = DistributedMeter(MpiTimerGauge()) + select case (this%getProcessRank()) + case (0) + call distributed%add_cycle(1.0_REAL64) + call distributed%add_cycle(3.0_REAL64) + case (1) + call distributed%add_cycle(2.0_REAL64) + end select + call distributed%reduce(this%getMpiCommunicator(), 0._REAL64) + + distributed_num_cycles = distributed%get_stats_num_cycles() + + if (this%getProcessRank() == 0) then + ! Some of these are meaningless/pointless + @assertEqual(3, distributed_num_cycles%total) + @assertEqual(1, distributed_num_cycles%min) + @assertEqual(2, distributed_num_cycles%max) + + @assertEqual(1, distributed_num_cycles%min_pe) + @assertEqual(0, distributed_num_cycles%max_pe) + @assertEqual(2, distributed_num_cycles%num_pes) + end if + + end subroutine test_get_num_cycles + +end module test_DistributedMeter diff --git a/MAPL_Profiler/tests/test_ExclusiveColumn.pf b/MAPL_Profiler/tests/test_ExclusiveColumn.pf new file mode 100644 index 000000000000..e570bde34550 --- /dev/null +++ b/MAPL_Profiler/tests/test_ExclusiveColumn.pf @@ -0,0 +1,46 @@ +module test_ExclusiveColumn + use funit + use MAPL_Profiler + use GFTL_UnlimitedVector + +contains + + @test + subroutine test_simple() + type(MeterNode), target :: node + class(AbstractMeterNode), pointer :: subnode + class(AbstractMeter), pointer :: t + type(ExclusiveColumn) :: c + type(UnlimitedVector) :: v + integer :: i + integer :: expected(3) + class(*), allocatable :: q + + node = MeterNode('top', AdvancedMeter(MpiTimerGauge())) + t => node%get_meter() + call t%add_cycle(10.0d0) + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + subnode => node%get_child('a') + t => subnode%get_meter() + call t%add_cycle(1.0d0) + + call node%add_child('b', AdvancedMeter(MpiTimerGauge())) + subnode => node%get_child('b') + t => subnode%get_meter() + call t%add_cycle(2.0d0) + + v = c%get_rows(node) + expected = [7,1,2] + do i = 1, 3 + q = v%at(i) + select type (q) + type is (integer) + @assertEqual(expected(i), q) + end select + end do + + end subroutine test_simple + + +end module test_ExclusiveColumn diff --git a/MAPL_Profiler/tests/test_MeterNode.pf b/MAPL_Profiler/tests/test_MeterNode.pf new file mode 100644 index 000000000000..28d975649983 --- /dev/null +++ b/MAPL_Profiler/tests/test_MeterNode.pf @@ -0,0 +1,141 @@ +module test_MeterNode + use, intrinsic :: iso_fortran_env, only: REAL64 + use funit + use MAPL_Profiler + implicit none + + +contains + + + @test + subroutine test_get_inclusive() + type (MeterNode), target:: node + class (AbstractMeter), pointer :: root_meter + class (AbstractMeter), pointer :: submeter + class (AbstractMeterNode), pointer :: child + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + + call node%add_child('sub1', AdvancedMeter(MpiTimerGauge())) + + root_meter => node%get_meter() + child => node%get_child('sub1') + submeter => child%get_meter() + + call submeter%add_cycle(1.0_REAL64) + call root_meter%add_cycle(3.0_REAL64) + @assertEqual(3.0, node%get_inclusive()) + + end subroutine test_get_inclusive + + + @test + subroutine test_get_exclusive() + type (MeterNode), target:: node + class (AbstractMeter), pointer :: root_meter + class (AbstractMeter), pointer :: submeter + class (AbstractMeterNode), pointer :: child + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + call node%add_child('sub1', AdvancedMeter(MpiTimerGauge())) + + root_meter => node%get_meter() + child => node%get_child('sub1') + submeter => child%get_meter() + + call submeter%add_cycle(1.0_REAL64) + call root_meter%add_cycle(3.0_REAL64) + @assertEqual(2.0, node%get_exclusive()) + + end subroutine test_get_exclusive + + + @test + subroutine test_get_num_nodes() + type (MeterNode) :: node + class (AbstractMeterNode), pointer :: child + + @assertEqual(1, node%get_num_nodes()) + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + @assertEqual(2, node%get_num_nodes()) + + call node%add_child('b', AdvancedMeter(MpiTimerGauge())) + @assertEqual(3, node%get_num_nodes()) + + child => node%get_child('a') + call child%add_child('cat', AdvancedMeter(MpiTimerGauge())) + call child%add_child('dog', AdvancedMeter(MpiTimerGauge())) + call child%add_child('fish', AdvancedMeter(MpiTimerGauge())) + + @assertEqual(6, node%get_num_nodes()) + + + end subroutine test_get_num_nodes + + @test + subroutine test_get_num_nodes_2() + type (MeterNode) :: node + class (AbstractMeterNode), pointer :: child + + @assertEqual(1, node%get_num_nodes()) + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('a') + call child%add_child('1', AdvancedMeter(MpiTimerGauge())) + call child%add_child('2', AdvancedMeter(MpiTimerGauge())) + + call node%add_child('b', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('b') + call child%add_child('1', AdvancedMeter(MpiTimerGauge())) + call child%add_child('2', AdvancedMeter(MpiTimerGauge())) + + @assertEqual(7, node%get_num_nodes()) + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) ! should already exist + + @assertEqual(7, node%get_num_nodes()) + + + end subroutine test_get_num_nodes_2 + + + @test + subroutine test_node_reset() + type (MeterNode) :: node + + class (AbstractMeter), pointer :: root_meter + class (AbstractMeter), pointer :: submeter + class (AbstractMeterNode), pointer :: child, grandchild + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + call node%add_child('A', AdvancedMeter(MpiTimerGauge())) + + root_meter => node%get_meter() + child => node%get_child('A') + submeter => child%get_meter() + + call submeter%add_cycle(10.0_REAL64) + + call child%add_child('A1', AdvancedMeter(MpiTimerGauge())) + call child%add_child('A2', AdvancedMeter(MpiTimerGauge())) + + grandchild => child%get_child('A1') + submeter => grandchild%get_meter() + call submeter%add_cycle(2.0_REAL64) + + grandchild => child%get_child('A2') + submeter => grandchild%get_meter() + call submeter%add_cycle(3.0_REAL64) + + call node%reset() + + @assertEqual(0, node%get_inclusive()) + @assertEqual(0, child%get_inclusive()) + @assertEqual(0, grandchild%get_inclusive()) + + end subroutine test_node_reset + + + +end module test_MeterNode diff --git a/MAPL_Profiler/tests/test_MeterNodeIterator.pf b/MAPL_Profiler/tests/test_MeterNodeIterator.pf new file mode 100644 index 000000000000..4e15735d2a3b --- /dev/null +++ b/MAPL_Profiler/tests/test_MeterNodeIterator.pf @@ -0,0 +1,180 @@ +module test_MeterNodeIterator + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_Profiler + use funit + implicit none + +contains + + @test + subroutine test_next_trivial() + type (MeterNode), target :: node + + class (AbstractMeterNodeIterator), allocatable :: iter_1 + class (AbstractMeterNodeIterator), allocatable :: iter_2 + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + + iter_1 = node%begin() + iter_2 = node%begin() + @assertTrue(iter_1 == iter_2) + @assertFalse(iter_1 /= iter_2) + @assertTrue(iter_1 /= node%end()) + @assertFalse(iter_1 == node%end()) + + call iter_1%next() + @assertTrue(iter_1 == node%end()) + @assertFalse(iter_1 == iter_2) + @assertFalse(iter_1 == iter_2) + @assertFalse(iter_2 == iter_1) + @assertTrue(iter_1 /= iter_2) + @assertTrue(iter_2 /= iter_1) + + call iter_2%next() + @assertTrue(iter_2 == node%end()) + @assertFalse(iter_2 /= node%end()) + @assertTrue(iter_1 == iter_2) + @assertFalse(iter_1 /= iter_2) + + end subroutine test_next_trivial + + @test + subroutine test_next_one_child() + type (MeterNode) :: node + + class (AbstractMeterNodeIterator), allocatable :: iter_1 + class (AbstractMeterNodeIterator), allocatable :: iter_2 + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + iter_1 = node%begin() + iter_2 = node%begin() + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + + call iter_1%next() + call iter_2%next() + @assertTrue(iter_1 == iter_2) + @assertFalse(iter_1 /= iter_2) + + call iter_1%next() + call iter_2%next() + @assertTrue(iter_1 == iter_2) + @assertFalse(iter_1 /= iter_2) + + end subroutine test_next_one_child + + @test + subroutine test_count_nodes_depth_0() + type (MeterNode), target :: node + + class (AbstractMeterNodeIterator), allocatable :: iter + integer :: count + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + + count = 0 + iter = node%begin() + do while (iter /= node%end()) + count = count + 1 + call iter%next() + end do + + @assertEqual(node%get_num_nodes(), count) + + + end subroutine test_count_nodes_depth_0 + + + @test + subroutine test_count_nodes_depth_1() + type (MeterNode), target :: node + + class (AbstractMeterNodeIterator), allocatable :: iter + integer :: count + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + call node%add_child('b', AdvancedMeter(MpiTimerGauge())) + call node%add_child('c', AdvancedMeter(MpiTimerGauge())) + + count = 0 + iter = node%begin() + do while (iter /= node%end()) + count = count + 1 + call iter%next() + end do + + @assertEqual(node%get_num_nodes(), count) + + + end subroutine test_count_nodes_depth_1 + + + ! The next test verifies that the desired pointer is retrieved at each level. + + @test + subroutine test_depth_2() + type (MeterNode), target :: node + + class (AbstractMeterNodeIterator), allocatable :: iter + class (AbstractMeterNode), pointer :: child, child_2 + class (AbstractMeter), pointer :: t + integer :: count + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + t => node%get_meter() + call t%add_cycle(1.0_REAL64) + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('a') + t => child%get_meter() + call t%add_cycle(2.0_REAL64) + + call child%add_child('a_1', AdvancedMeter(MpiTimerGauge())) + child_2 => child%get_child('a_1') + t => child_2%get_meter() + call t%add_cycle(3.0_REAL64) + + call child%add_child('a_2', AdvancedMeter(MpiTimerGauge())) + child_2 => child%get_child('a_2') + t => child_2%get_meter() + call t%add_cycle(4.0_REAL64) + + call node%add_child('b', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('b') + t => child%get_meter() + call t%add_cycle(5.0_REAL64) + + call child%add_child('b_1', AdvancedMeter(MpiTimerGauge())) + child_2 => child%get_child('b_1') + t => child_2%get_meter() + call t%add_cycle(6.0_REAL64) + + call child%add_child('b_2', AdvancedMeter(MpiTimerGauge())) + child_2 => child%get_child('b_2') + t => child_2%get_meter() + call t%add_cycle(7.0_REAL64) + + call node%add_child('c', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('c') + t => child%get_meter() + call t%add_cycle(8.0_REAL64) + + + count = 0 + iter = node%begin() + do while (iter /= node%end()) + count = count + 1 + t => iter%get_meter() + @assertEqual(count, t%get_total()) + call iter%next() + end do + + @assertEqual(8, count) + + end subroutine test_depth_2 + + + +end module test_MeterNodeIterator + diff --git a/MAPL_Profiler/tests/test_NameColumn.pf b/MAPL_Profiler/tests/test_NameColumn.pf new file mode 100644 index 000000000000..dc5847aa6eab --- /dev/null +++ b/MAPL_Profiler/tests/test_NameColumn.pf @@ -0,0 +1,53 @@ +module test_NameColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_Profiler + use funit + +contains + + + @test + subroutine test_one_timer() + type (NameColumn) :: column + type (MeterNode), target :: node + integer, parameter :: WIDTH = 10 + character(:), allocatable :: header(:) + + node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) + column = NameColumn(width=WIDTH) + + ! Check proper padding. + call column%get_header(header) + @assertEqual(WIDTH, len(header)) + @assertEqual(WIDTH, len(column%get_row(node))) + @assertEqual('Name ',header(1)) + @assertEqual('all ',column%get_row(node)) + + end subroutine test_one_timer + + @test + subroutine test_get_rows() +!!$ type (NameColumn) :: column +!!$ type (MeterNode), target :: node +!!$ integer, parameter :: WIDTH = 10 +!!$ character(len=WIDTH) :: expected(3) +!!$ character(:), allocatable :: found(:) +!!$ +!!$ node = MeterNode('all', AdvancedMeter(MpiTimerGauge())) +!!$ call node%add_child('t1', AdvancedMeter(MpiTimerGauge())) +!!$ call node%add_child('t2', AdvancedMeter(MpiTimerGauge())) +!!$ +!!$ column = NameColumn(width=WIDTH) +!!$ +!!$ expected(1) = 'all' +!!$ expected(2) = '--t1' +!!$ expected(3) = '--t2' +!!$ +!!$ call column%get_rows(node, found) +!!$ do i = 1, 3 +!!$ @assertEqual(expected(i), found(i)) +!!$ end do + + end subroutine test_get_rows + +end module test_NameColumn diff --git a/MAPL_Profiler/tests/test_PercentageColumn.pf b/MAPL_Profiler/tests/test_PercentageColumn.pf new file mode 100644 index 000000000000..2d3047938346 --- /dev/null +++ b/MAPL_Profiler/tests/test_PercentageColumn.pf @@ -0,0 +1,44 @@ +module test_PercentageColumn + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL_Profiler + use funit + use GFTL_UnlimitedVector + +contains + + @test + subroutine test_percent_inclusive() + use, intrinsic :: iso_fortran_env, only: REAL64 + type (PercentageColumn) :: c + type (MeterNode), target :: node + class (AbstractMeterNode), pointer :: child + class (AbstractMeter), pointer :: t + type(UnlimitedVector) :: v + integer :: i + integer :: expected(2) + class(*), allocatable :: q + + node = MeterNode('foo', AdvancedMeter(MpiTimerGauge())) + t => node%get_meter() + call t%add_cycle(10.0_REAL64) + + call node%add_child('a', AdvancedMeter(MpiTimerGauge())) + child => node%get_child('a') + t => child%get_meter() + call t%add_cycle(5.0_REAL64) + + c = PercentageColumn(InclusiveColumn(),'MAX') + + v = c%get_rows(node) + expected = [100.,50.] + do i = 1, 2 + q = v%at(i) + select type (q) + type is (real(kind=REAL64)) + @assertEqual(expected(i), q) + end select + end do + + end subroutine test_percent_inclusive + +end module test_PercentageColumn diff --git a/MAPL_Profiler/tests/test_ProfileReporter.pf b/MAPL_Profiler/tests/test_ProfileReporter.pf new file mode 100644 index 000000000000..86b75f1c7b61 --- /dev/null +++ b/MAPL_Profiler/tests/test_ProfileReporter.pf @@ -0,0 +1,122 @@ +module test_ProfileReporter + use funit + use MAPL_Profiler + implicit none + + character(1) :: empty(0) + +contains + + + @test + subroutine test_simple_report_timer() + type (TimeProfiler), target :: prof + type (ProfileReporter), target :: reporter + + character(:), allocatable :: report_lines(:) + + prof = TimeProfiler('top') ! timer 1 + call prof%start() + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%start('timer_1b') ! 4 + call prof%start('timer_1b1') ! 5 + call prof%stop('timer_1b1') + call prof%stop('timer_1b') + call prof%stop('timer_1') + call prof%start('timer_2') ! 6 + call prof%start('timer_2b')! 7 + call prof%stop('timer_2b') + call prof%stop('timer_2') + + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%stop('timer_1') + + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + + call prof%finalize() + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('# cycles','(i8.0)', 8, NumCyclesColumn())) + allocate(report_lines, source=reporter%generate_report(prof)) + + @assertEqual(1 + 7, size(report_lines)) + @assertEqual(20 + 1 + 8, len(report_lines(1))) + + @assertEqual('Name # cycles', report_lines(1)) + @assertEqual('top 1', report_lines(2)) + @assertEqual('--timer_1 2', report_lines(3)) + @assertEqual('----timer_1a 2', report_lines(4)) + @assertEqual('----timer_1b 1', report_lines(5)) + @assertEqual('------timer_1b1 1', report_lines(6)) + @assertEqual('--timer_2 3', report_lines(7)) + @assertEqual('----timer_2b 1', report_lines(8)) + + end subroutine test_simple_report_timer + + + @test + subroutine test_simple_report_timer_b() + type (TimeProfiler), target :: prof + type (ProfileReporter) :: reporter + + character(:), allocatable :: report_lines(:) + + prof = TimeProfiler('top') ! timer 1 + call prof%start() + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%start('timer_1b') ! 4 + call prof%start('timer_1b1') ! 5 + call prof%stop('timer_1b1') + call prof%stop('timer_1b') + call prof%stop('timer_1') + call prof%start('timer_2') ! 6 + call prof%start('timer_2b')! 7 + call prof%stop('timer_2b') + call prof%stop('timer_2') + + call prof%start('timer_1') ! 2 + call prof%start('timer_1a')! 3 + call prof%stop('timer_1a') + call prof%stop('timer_1') + + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + call prof%start('timer_2') ! 6 + call prof%stop('timer_2') + + call prof%finalize() + + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('# cycles','(i8.0)', 8, NumCyclesColumn())) + call reporter%add_column(FormattedTextColumn('T(incl)','(f15.6)', 15, InclusiveColumn())) + report_lines = reporter%generate_report(prof) + + @assertEqual(1 + 7, size(report_lines)) + @assertEqual(20 + 1 + 8 + 1 + 15, len(report_lines(1))) + + @assertEqual('Name # cycles', report_lines(1)(1:29)) + @assertEqual('top 1', report_lines(2)(1:29)) + @assertEqual('--timer_1 2', report_lines(3)(1:29)) + @assertEqual('----timer_1a 2', report_lines(4)(1:29)) + @assertEqual('----timer_1b 1', report_lines(5)(1:29)) + @assertEqual('------timer_1b1 1', report_lines(6)(1:29)) + @assertEqual('--timer_2 3', report_lines(7)(1:29)) + @assertEqual('----timer_2b 1', report_lines(8)(1:29)) + + end subroutine test_simple_report_timer_b + + + +end module test_ProfileReporter diff --git a/MAPL_Profiler/tests/test_TimeProfiler.pf b/MAPL_Profiler/tests/test_TimeProfiler.pf new file mode 100644 index 000000000000..2fd33440e896 --- /dev/null +++ b/MAPL_Profiler/tests/test_TimeProfiler.pf @@ -0,0 +1,126 @@ +module test_TimeProfiler + use funit + use MAPL_Profiler + implicit none + + +contains + + + @test + subroutine test_start_one() + type (TimeProfiler), target :: prof + + prof = TimeProfiler('top') + call Prof%start() + + call prof%start('timer_1') + call prof%stop('timer_1') + + call prof%finalize() + + @assertEqual(2, prof%get_num_meters()) + + end subroutine test_start_one + + + @test + subroutine test_stop_wrong_meter() + type (TimeProfiler), target :: prof + + prof = TimeProfiler('top') + call prof%start() + + call prof%start('timer_1') + call prof%start('timer_2') + @assertEqual(0, prof%get_status()) + call prof%stop('timer_1') ! not the current timer + + @assertEqual(INCORRECTLY_NESTED_METERS, prof%get_status()) + call prof%finalize() + + end subroutine test_stop_wrong_meter + + @test + subroutine test_accumulate_sub() + type(TimeProfiler), target :: main, lap + class(AbstractMeterNode), pointer :: main_node + + main = TimeProfiler('main') + call main%start() + lap = TimeProfiler('lap') + call lap%start() + call lap%finalize() + call main%accumulate(lap) + + ! should now have 'lap' as a subtimer of 'main' + @assertEqual(2, main%get_num_meters()) + + main_node => main%get_root_node() + @assertTrue(main_node%has_child('lap')) + + end subroutine test_accumulate_sub + + + @test + subroutine test_accumulate_nested() + type(TimeProfiler), target :: main, lap + class(AbstractMeterNode), pointer :: main_node + class(AbstractMeterNode), pointer :: child + class(AbstractMeter), pointer :: t + + main = TimeProfiler('main') + call main%start() + lap = TimeProfiler('lap') + call lap%start() + call lap%start('A') + call lap%stop('A') + call lap%finalize() + call main%accumulate(lap) + + ! should now have 'lap' as a subtimer of 'main' + @assertEqual(3, main%get_num_meters()) + + main_node => main%get_root_node() + @assertTrue(main_node%has_child('lap')) + + child => main_node%get_child('lap') + t => child%get_meter() + select type (t) + class is (AdvancedMeter) + @assertEqual(1, t%get_num_cycles()) + end select + + @assertTrue(child%has_child('A')) + child => child%get_child('A') + t => child%get_meter() + select type (t) + class is (AdvancedMeter) + @assertEqual(1, t%get_num_cycles()) + end select + + end subroutine test_accumulate_nested + + @test + subroutine test_accumulate_multi() + type(TimeProfiler), target :: main, lap + + main = TimeProfiler('main') + call main%start() + lap = TimeProfiler('lap') + call lap%start() + call lap%start('A') + call lap%stop('A') + call lap%finalize() + call main%accumulate(lap) + + call lap%reset() + call lap%start('A') + call lap%stop('A') + call lap%finalize() + call main%accumulate(lap) + + + end subroutine test_accumulate_multi + +end module test_TimeProfiler diff --git a/MAPL_cfio/ESMF_CFIOGridMod.F90 b/MAPL_cfio/ESMF_CFIOGridMod.F90 index 7d11da58d08c..7b88b533c554 100644 --- a/MAPL_cfio/ESMF_CFIOGridMod.F90 +++ b/MAPL_cfio/ESMF_CFIOGridMod.F90 @@ -191,7 +191,7 @@ subroutine ESMF_CFIOGridSet (grid, gName, im, jm, km, tm, lat, lon, lev,& !------------------------------------------------------------------------------ integer :: rtcode = 0 integer :: i, j - integer :: sz + !integer :: sz _UNUSED_DUMMY(sigma) _UNUSED_DUMMY(reduceGrid) diff --git a/MAPL_cfio/ESMF_CFIOSdfMod.F90 b/MAPL_cfio/ESMF_CFIOSdfMod.F90 index 5263f9b9e519..b6e06563f88d 100644 --- a/MAPL_cfio/ESMF_CFIOSdfMod.F90 +++ b/MAPL_cfio/ESMF_CFIOSdfMod.F90 @@ -106,11 +106,10 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) !EOP !------------------------------------------------------------------------------ integer :: i, rtcode - integer :: maxLen + !integer :: maxLen character(len=MLEN) :: fNameTmp ! file name integer :: date, begTime character(len=MLEN) :: fName - character(len=MLEN) :: string call ESMF_CFIOGet(cfio, date=date, begTime=begTime, fName=fName, rc=rtcode) if (rtcode .ne. 0) print *, "Problems in ESMF_CFIOGet" @@ -372,9 +371,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) integer :: nvatts ! number of attributes real*4, pointer :: rtmp(:) integer, pointer :: itmp(:) - character(len=MVARLEN), pointer :: ctmp(:) logical :: esmf_file = .false. - logical :: tmpLog logical :: new_grid integer :: nDims, allVars, recdim integer :: im, jm, km @@ -3802,7 +3799,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 integer rtcode integer begDate, begTime, incSecs, timeIndex1, timeIndex2 integer secs, secs1, secs2, nymd1, nymd2, nhms1, nhms2 - integer i, j, k + integer i, j integer im, jm, km real alpha, amiss diff --git a/MAPL_cfio/ESMF_CFIOUtilMod.F90 b/MAPL_cfio/ESMF_CFIOUtilMod.F90 index 8353de4cda14..ef01ad772277 100644 --- a/MAPL_cfio/ESMF_CFIOUtilMod.F90 +++ b/MAPL_cfio/ESMF_CFIOUtilMod.F90 @@ -655,9 +655,11 @@ subroutine GetDateTimeVec ( fid, begDate, begTime, incVec, rc ) !EOP !------------------------------------------------------------------------- - integer i, timeId, hour, min, sec, corner(1), timInc, incSecs + integer i, timeId, hour, min, sec, corner(1) + !integer incSecs integer year, month, day - character(len=MAXCHR) timeUnits, strTmp, dimUnits + character(len=MAXCHR) timeUnits, dimUnits + !character(len=MAXCHR) strTmp character*(MAXCHR) varName, dimName, stdName integer type, nvDims, vdims(MAXVDIMS), nvAtts, dimSize @@ -668,10 +670,11 @@ subroutine GetDateTimeVec ( fid, begDate, begTime, incVec, rc ) real*8 dtime, dtime_array(1) integer*2 itime, itime_array(1) integer*4 ltime, ltime_array(1) - integer t1, t2, tMult, newDate, newTime + !integer t1 + integer newDate, newTime ! We now have the possibility of a very large interval - integer(Kind=INT64) :: t1Long, t2Long, tMax, tMultLong, incSecsLong + integer(Kind=INT64) :: t1Long, t2Long, tMultLong, incSecsLong integer(Kind=INT64),allocatable :: incVecLong(:) ! Vector of offsets (seconds) ! Get the starting date and time @@ -1326,8 +1329,6 @@ subroutine CFIO_Close ( fid, rc ) !EOP !------------------------------------------------------------------------- - integer i - call ncclos (fid, rc) if (err("Close: error closing file",rc,-54) .NE. 0) return @@ -2311,8 +2312,8 @@ subroutine ParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec, rc ) ! Local variables - integer ypos(2), mpos(2), dpos(2), hpos(2), minpos(2), spos(2) - integer inew, strlen + integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) + integer strlen integer firstdash, lastdash integer firstcolon, lastcolon integer lastspace @@ -2865,7 +2866,7 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& integer corner(3), edges(3), timeIndex integer vid integer i,j,k - integer incSecs + !integer incSecs logical stationFile integer(INT64), allocatable :: incVec(:) @@ -2878,7 +2879,7 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& integer dimSize, dimId integer nDims,nvars,ngatts integer varType, myIndex - integer timeShift + !integer timeShift ! Variables for dealing with precision @@ -3240,11 +3241,11 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& !------------------------------------------------------------------------- integer begDate, begTime, seconds, minutes - integer timeShift + !integer timeShift integer corner(5), edges(5), timeIndex integer vid integer i,j,k - integer incSecs + !integer incSecs integer(INT64), allocatable :: incVec(:) ! Variables for working with dimensions @@ -4049,10 +4050,9 @@ subroutine GetDateInt8 (yyyymmdd_1,hhmmss_1,offset, & !------------------------------------------------------------------------- integer year1,mon1,day1,hour1,min1,sec1 integer year2,mon2,day2,hour2,min2,sec2 - integer seconds1, seconds2 - integer(kind=INT64) julian1, julian2 + integer(kind=INT64) julian1 integer(kind=INT64) julsec, remainder - character*8 dateString + !character*8 dateString ! Error checking. @@ -4207,7 +4207,6 @@ real function CFIO_GetMissing ( fid, rc ) character*(MAXCHR) vnameTemp integer i logical surfaceOnly - logical noTimeInfo integer attType, attLen integer allVars ! all variables - includes dimension vars diff --git a/MAPL_pFUnit/CMakeLists.txt b/MAPL_pFUnit/CMakeLists.txt index 8674e890b13e..f0c2185053b6 100644 --- a/MAPL_pFUnit/CMakeLists.txt +++ b/MAPL_pFUnit/CMakeLists.txt @@ -9,8 +9,8 @@ set (srcs esma_add_library (${this} EXCLUDE_FROM_ALL SRCS ${srcs}) -include_directories (${INC_ESMF}) -include_directories (${INC_NETCDF}) +target_include_directories (${this} PRIVATE ${INC_ESMF}) +target_include_directories (${this} PRIVATE ${INC_NETCDF}) target_link_libraries (${this} ${ESMF_LIBRARIES} pfunit) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) diff --git a/MAPL_pFUnit/ESMF_TestParameter.F90 b/MAPL_pFUnit/ESMF_TestParameter.F90 index a847e1e8ba83..c1e0a2bee63c 100644 --- a/MAPL_pFUnit/ESMF_TestParameter.F90 +++ b/MAPL_pFUnit/ESMF_TestParameter.F90 @@ -1,3 +1,5 @@ +#include "unused_dummy.H" + module ESMF_TestParameter_mod use pfunit, only: MpiTestParameter implicit none @@ -67,6 +69,7 @@ end function toStringActual function toString(this) result(string) class (ESMF_TestParameter), intent(in) :: this character(:), allocatable :: string + _UNUSED_DUMMY(this) string = '' diff --git a/MAPL_Base/unused_dummy.H b/MAPL_pFUnit/unused_dummy.H similarity index 100% rename from MAPL_Base/unused_dummy.H rename to MAPL_pFUnit/unused_dummy.H diff --git a/Python/DataSpec.py b/Python/DataSpec.py deleted file mode 100644 index 6acd9fa1a00d..000000000000 --- a/Python/DataSpec.py +++ /dev/null @@ -1,97 +0,0 @@ -class DataSpec: - """Declare and manipulate an import/export/internal specs for a - MAPL Gridded component""" - - mandatory_options = ['DIMS', 'SHORT_NAME'] - # The following must be quoted when emitted as Fortran source. - stringlike_options = ['SHORT_NAME', 'LONG_NAME', 'UNITS'] - # The following should NOT be quoted when emitted as Fortran source. - literal_options = ['DIMS', 'VLOCATION', 'NUM_SUBTILES', - 'REFRESH_INTERVAL', 'AVERAGING_INTERVAL', 'HALOWIDTH', - 'PRECISION','DEFAULT','RESTART', 'UNGRIDDED_DIMS', - 'FIELD_TYPE', 'STAGGERING', 'ROTATION'] - all_options = stringlike_options + literal_options - - - def __init__(self, category, args, indent=3): - self.category = category - self.args = args - self.indent = indent - self.has_condition = 'CONDITION' in self.args and DataSpec.not_empty(self.args['CONDITION']) - - - def not_empty(string): - return string and not string.isspace() - - def newline(self): - return "\n" + " "*self.indent - - def continue_line(self): - return "&" + self.newline() + "& " - - def emit_declare_spec(self): - return self.wrap_conditional(self.emit_MAPL_AddSpec) - - def wrap_conditional(self, content_method): - text = self.newline() - if self.has_condition: - text = text + "if (" + self.args['CONDITION'] + ") then" - self.indent = self.indent + 3 - text = text + self.newline() - text = text + content_method() - if self.has_condition: - self.indent = self.indent - 3 - text = text + self.newline() - text = text + "endif" - return text + self.newline() - - def get_rank(self): - gridded_ranks = {'MAPL_DimsHorzVert':3, 'MAPL_DimsHorzOnly':2, 'MAPL_DimsVertOnly':1} - if 'UNGRIDDED_DIMS' in self.args: - extra_dims = self.args['UNGRIDDED_DIMS'].strip('][').split(',') - extra_rank = len(extra_dims) - else: - extra_rank = 0 - return gridded_ranks[self.args['DIMS']] + extra_rank - - def emit_declare_local_variable(self): - return self.wrap_conditional(self.emit_MAPL_declare_local_variable) - - def emit_MAPL_declare_local_variable(self): - type = 'real' - kind = 'REAL32' - rank = self.get_rank() - dimension = 'dimension(:' + ',:'*(rank-1) + ')' - text = type + '(kind=' + str(kind) + '), ' + dimension + ' :: ' + self.args['LOCAL_NAME'] + ' => null()' - return text - - def emit_get_pointer(self): - return self.wrap_conditional(self.emit_MAPL_GetPointer) - - def emit_MAPL_GetPointer(self): - text = "call MAPL_GetPointer(" + self.category + ', ' + self.args['LOCAL_NAME'] + ", '" + self.args['SHORT_NAME'] + "', rc=status); VERIFY_(status)" - return text - - - def emit_MAPL_AddSpec(self): - self.indent = self.indent + 5 - text = "call MAPL_Add" + self.category + "Spec(" + self.continue_line() - for option in DataSpec.all_options: - text = text + self.emit_arg(option) - text = text + 'rc=status)' + self.newline() - self.indent = self.indent - 5 - text = text + 'VERIFY_(status)' - return text - - def emit_arg(self, option): - text = '' - if option in self.args: - value = self.args[option] - text = text + option + "=" - if option in DataSpec.stringlike_options: - value = "'" + value + "'" - text = text + value + ", " + self.continue_line() - return text - - - diff --git a/Python/DataSpecsReader.py b/Python/DataSpecsReader.py deleted file mode 100644 index 2b45594cd80b..000000000000 --- a/Python/DataSpecsReader.py +++ /dev/null @@ -1,38 +0,0 @@ -import csv -import pandas as pd - -def read(specs_filename): - - def csv_record_reader(csv_reader): - """ Read a csv reader iterator until a blank line is found. """ - prev_row_blank = True - for row in csv_reader: - if not (len(row) == 0): - if row[0].startswith('#'): - continue - yield row - prev_row_blank = False - elif not prev_row_blank: - return - - specs = {} - with open(specs_filename, 'r') as specs_file: - specs_reader = csv.reader(specs_file, skipinitialspace=True) - while True: - try: - gen = csv_record_reader(specs_reader) - category = next(gen)[0] - columns = next(gen) - specs[category] = pd.DataFrame(gen, columns=columns) - except StopIteration: - break - - if '*ALIASES*' in specs: - for alias in specs['*ALIASES*'].to_dict('records'): - specs['IMPORT'].replace({alias['OPTION']:{alias['ALIAS']:alias['VALUE']}},inplace=True) - specs['EXPORT'].replace({alias['OPTION']:{alias['ALIAS']:alias['VALUE']}},inplace=True) - specs['INTERNAL'].replace({alias['OPTION']:{alias['ALIAS']:alias['VALUE']}},inplace=True) - - return specs - - diff --git a/Python/MAPL/Abstract.py b/Python/MAPL/Abstract.py new file mode 100644 index 000000000000..b6edda13a460 --- /dev/null +++ b/Python/MAPL/Abstract.py @@ -0,0 +1,15 @@ +class Method (object): + def __init__(self, func): + self._function = func + + def __get__(self, obj, type): + return self.AbstractMethodHelper(self._function, type) + + class AbstractMethodHelper (object): + def __init__(self, func, cls): + self._function = func + self._class = cls + + def __call__(self, *args, **kwargs): + raise NotImplementedError('Abstract method `' + self._class.__name__ \ + + '.' + self._function + '\' called') diff --git a/Python/MAPL/Date.py b/Python/MAPL/Date.py new file mode 100644 index 000000000000..60e73a5ec4b5 --- /dev/null +++ b/Python/MAPL/Date.py @@ -0,0 +1,354 @@ +""" +The module defines a class Date and several methods to deal with it, including conversions. + +The "format" of the Date class is as follows: Each instance has three attributes, +year, month and day, all represented as integers and writable. Although no constraints are +enforced, the intended range of values is: + +1 <= day <= 31 (more precisely 1 <= day <= NumberDaysMonth(month, year)) +1 <= month <= 12 (1 is January and 12 is December) + +It is up to the client of this class to make sure that all assignments are correct. + +In making conversions with the time module (wether in seconds or in a 9-tuple) local time +is always used. + +History of changes: +version 2.0.1: + - Added docstring to the module. + - Changed implementation of next() and previous() to take advantage of NumberDaysMonth(). + +version 2.0: Complete rewrite of the module. + - Removed weekday as instance attribute of the class. + - Added conversion to and from Julian Day number. Added NumberDaysMonth function. Added + __sub__ and __add__. Made the class hashable. + - Added some (still insuficient and completely ad-hoc) test code when run as __main__. +""" + +__version__ = 2.01 +__author__ = "G. Rodrigues" + +import time + +#Needed for conversion to COM dates. +try: + import pythoncom +except: + pass + +def IsLeapYear(year): + """Returns 1 if year is a leap year, zero otherwise.""" + if year%4 == 0: + if year%100 == 0: + if year%400 == 0: + return 1 + else: + return 0 + else: + return 1 + else: + return 0 + +def NumberDaysYear(year): + """Returns the number of days in the year.""" + return 365 + IsLeapYear(year) + +def NumberDaysMonth(month = None, year = None): + """Returns the number of days in the month. + + If any of the arguments is missing (month or year) the current month/year is assumed.""" + if month is None: + m = time.localtime()[1] + else: + m = month + + if year is None: + y = time.localtime()[0] + else: + y = year + + if m == 2: + if IsLeapYear(y): + return 29 + else: + return 28 + elif m in (1, 3, 5, 7, 8, 10, 12): + return 31 + else: + return 30 + + +class Date(object): + """The Date class.""" + + Weekdays = ["Monday", + "Tuesday", + "Wednesday", + "Thursday", + "Friday", + "Saturday", + "Sunday"] + + Months = ["January", + "February", + "March", + "April", + "May", + "June", + "July", + "August", + "September", + "October", + "November", + "December"] + + #The slots in a Date object are constrained to allow more efficient operations. + __slots__ = ["year", "month", "day"] + + def __init__(self, tm = None): + """The initializer has an optional argument, time, in the time module format, + wether as in seconds since the epoch (Unix time) wether as a tuple (time tuple). + If it is not provided, then it returns the current date.""" + if tm is None: + t = time.localtime() + else: + if isinstance(tm, int): + t = time.localtime(tm) + else: + t = tm + + self.year, self.month, self.day = t[:3] + + def weekday(self): + """Returns the weekday of the date. + + The format is as in the time module: Monday is 0 and sunday is 6.""" + a = (14 - self.month)//12 + y = self.year - a + m = self.month + 12*a -2 + d = (self.day + y + y//4 - y//100 + y//400 + (31*m//12))%7 + if d: + ret = d - 1 + else: + ret = 6 + return ret + + def __str__(self): + return "%s, %d-%s-%d" % (Date.Weekdays[self.weekday()], + self.day, + Date.Months[self.month - 1], + self.year) + + def copy(self): + """Deep copy of Date objects.""" + ret = Date() + ret.year, ret.month, ret.day = self.year, self.month, self.day + return ret + + #The iterator protocol. The iteration is "destructive", like in files. + def __iter__(self): + return self + + def next(self): + #Last day of the month. + if self.day == NumberDaysMonth(self.month, self.year): + self.day = 1 + #December case. + if self.month == 12: + self.month = 1 + self.year += 1 + else: + self.month += 1 + else: + self.day += 1 + + #Extended iterator protocol. One can go backwards. + def previous(self): + #First day of the month. + if self.day == 1: + #January case. + if self.month == 1: + self.month = 12 + self.year -= 1 + else: + self.month -= 1 + self.day = NumberDaysMonth(self.month, self.year) + else: + self.day -= 1 + + #Comparison methods. + def __eq__(self, date): + return self.year == date.year and self.month == date.month and\ + self.day == date.day + + def __lt__(self, other): + return (self.year, self.month, self.day) < (other.year, other.month, other.day) + + def __le__(self, other): + return (self.year, self.month, self.day) <= (other.year, other.month, other.day) + + #Dates can be used as keys in dictionaries. + def __hash__(self): + return hash((self.year, self.month, self.day)) + + #Some useful methods. + def GetYearDay(self): + """Returns the year day of a date.""" + ret = self.day + for month in range(1, self.month): + ret += NumberDaysMonth(month, self.year) + return ret + + def DaysToEndYear(self): + """Returns the number of days until the end of the year.""" + ret = NumberDaysMonth(self.month, self.year) - self.day + for i in range(self.month + 1, 13): + ret += NumberDaysMonth(i, self.year) + return ret + + def GetWeekday(self): + """Returns the weekday of the date in string format.""" + return Date.Weekdays[self.weekday()] + + def GetMonth(self): + """Returns the month of the date in string format.""" + return Date.Months[self.month - 1] + + def ToJDNumber(self): + """Returns the Julian day number of a date.""" + a = (14 - self.month)//12 + y = self.year + 4800 - a + m = self.month + 12*a - 3 + return self.day + ((153*m + 2)//5) + 365*y + y//4 - y//100 + y//400 - 32045 + + #Binary operations. + def __add__(self, n): + """Adds a (signed) number of days to the date.""" + if isinstance(n, int): + #Calculate julian day number and add n. + temp = self.ToJDNumber() + n + #Convert back to date format. + return DateFromJDNumber(temp) + else: + raise TypeError, "%s is not an integer." % str(n) + + def __sub__(self, date): + """Returns the (signed) difference of days between the dates.""" + #If it is an integer defer calculation to the __add__ method. + if isinstance(date, int): + return self.__add__(-date) + elif isinstance(date, Date): + #Case: The years are equal. + if self.year == date.year: + return self.GetYearDay() - date.GetYearDay() + else: + if self < date: + ret = self.DaysToEndYear() + date.GetYearDay() + for year in range(self.year + 1, date.year): + ret += NumberDaysYear(year) + return -ret + else: + ret = date.DaysToEndYear() + self.GetYearDay() + for year in range(date.year + 1, self.year): + ret += NumberDaysYear(year) + return ret + else: + raise TypeError, "%s is neither an integer nor a Date." % str(date) + + #Adding an integer is "commutative". + def __radd__(self, n): + return self.__add__(n) + + #Conversion methods. + def ToTimeTuple(self): + """Convert a date into a time tuple (time module) corresponding to the + same day with the midnight hour.""" + ret = [self.year, self.month, self.day] + ret.extend([0, 0, 0]) + ret.append(self.weekday()) + ret.extend([self.GetYearDay(), 0]) + return tuple(ret) + + def ToUnixTime(self): + """Convert a date into Unix time (seconds since the epoch) corresponding + to the same day with the midnight hour.""" + return time.mktime(self.ToTimeTuple()) + + def ToCOMTime(self): + """Convert a date into COM format.""" + return pythoncom.MakeTime(self.ToUnixTime()) + + +#More conversion functions. +def DateFromJDNumber(n): + """Returns a date corresponding to the given Julian day number.""" + if not isinstance(n, int): + raise TypeError, "%s is not an integer." % str(n) + + a = n + 32044 + b = (4*a + 3)//146097 + c = a - (146097*b)//4 + d = (4*c + 3)//1461 + e = c - (1461*d)//4 + m = (5*e + 2)//153 + + ret = Date() + ret.day = e + 1 - (153*m + 2)//5 + ret.month = m + 3 - 12*(m//10) + ret.year = 100*b + d - 4800 + m/10 + return ret + +def DateFromCOM(t): + """Converts a COM time directly into the Date format.""" + return Date(int(t)) + +def strpdate(s): + """This function reads a string in the standard date representation + format and returns a date object.""" + ret = Date() + temp = s.split(", ") + temp = temp[1].split("-") + ret.year, ret.month, ret.day = (int(temp[2]), + Date.Months.index(temp[1]) + 1, + int(temp[0])) + return ret + + +#Some test code. +if __name__ == "__main__": + #Print the days still left in the month. + temp = Date() + curr_month = temp.month + while temp.month == curr_month: + print temp + temp.next() + + print "\n" + + #How many days until the end of the year? + temp = Date() + temp.day, temp.month = 1, 1 + curr_year = temp.year + while temp.year == curr_year: + print "%s is %d days away from the end of the year." % (str(temp), + temp.DaysToEndYear()) + temp += NumberDaysMonth(temp.month) + + print "\n" + + #Playing with __sub__. + temp = Date() + temp_list = [] + curr_year = temp.year + while temp.year == curr_year: + temp_list.append(temp) + temp += NumberDaysMonth(temp.month) + for elem in temp_list: + print "%s differs %d days from current date: %s" % (str(elem), + elem - Date(), + str(Date())) + + print "\n" + + #Swapping arguments works? + print 23 + Date() diff --git a/Python/MAPL/__init__.py b/Python/MAPL/__init__.py new file mode 100644 index 000000000000..329656a7e887 --- /dev/null +++ b/Python/MAPL/__init__.py @@ -0,0 +1,56 @@ +""" +This package contains foundation classes for assembling MAPL-based +systems using Python as the scripting language. At this stage of +development system are composed of MAPL-based Applications in the form +of stand alone executables (e.g., GEOSgcm.x). The following packages +define the basic functionality: + +exp + This package defines the base class *Exp* (as in *experiment*) which + controls the execution of a long *experiment*. Each experiment is + carried out by means of several *jobs* which are submitted through a + queueing system such as PBS. + +job + This package defines the base class *Job* which inherits from + *Exp*. A *job* carries out a portion of the *experiment*, + itself consisting of several *run* segments. + +run + This package defines the base class *Run* which inherits from + *Job* extending it with methods for running a single *segment* of a + job. A *run* segment consists of running the stand-alone Fortran + executable for a fixed period of time. + +config + This package defines the class Config providing functionality for + basic resource file management loosely based in the ESMF_Config + class. + +Typically, an application such as GEOSgcm would inherit from +*Run* and implement specific methods for dealing with its own +resource files, boundary contitions, restarts and pre- and +post-processing. + +Here is an illustration of an experiment consistng of 3 jobs, each +with 2 run segments. + + |----------------------- Experiment ------------------------| + |------ Job 1 ------|------ Job 2 ------|------ Job 3 ------| + |- Run 1 -|- Run 2 -|- Run 3 -|- Run 4 -|- Run 5 -|- Run 6 -| + +If each run segment is 2 weeks long, each job performs a 4 week +integration, and the the whole experiment is about 3 month long. + +""" + +__version__ = "0.1.2" + +from exp import * +from job import * +from run import * +from config import * +from history import * +from Date import * +from filelock import * + diff --git a/Python/MAPL/config.py b/Python/MAPL/config.py new file mode 100644 index 000000000000..36cedb329ab2 --- /dev/null +++ b/Python/MAPL/config.py @@ -0,0 +1,320 @@ +""" +A simpe implementation of a ESMF_Config-like class in Python. +Tables are not supported yet. + +""" + +__version__ = "0.1.0" + +import string +import re +import os +import sys +from types import * +from datetime import datetime + +class Config(object): + + def __init__(self,RcFiles,delim=':',Environ=True): + """ + Creates config object from one or more resource files. + If set to True, the *Environ* parameter will be used to + determined whether resource files are interpolated based on + the current value of environment variables. + """ + + if type(RcFiles) is StringType: + Files = ( RcFiles, ) # in case a single file is given + else: + Files = RcFiles # more often, a List/Tuple of RC files + + self.Rc = {} + self.delim = delim + for rcfile in Files: + self.Lines = open(rcfile).readlines() + for line in self.Lines: + line = line.rstrip() + name, value, comment = _parseLine(line,self.delim) + if Environ: + if value is not None: + value = string.Template(value).safe_substitute(os.environ) + if name: + self.Rc[name] = { 'value': value, + 'comment': comment, + 'flag': 0} + + def __call__(self,name,value=None): + """Either get or set a resource depending on whether *value* is given""" + if value == None: + if self.Rc.__contains__(name): + return self.Rc[name]['value'] + else: + if self.Rc.__contains__(name): + self.Rc[name]['value'] = value + self.Rc[name]['flag'] = 1 + return self.Rc[name]['value'] + return None + + get = __call__ + + def set(self,name,value): + return self.__call__(name,value) + + def save(self,rcfile=None): + """Save to resource file.""" + if rcfile is None: + f = sys.stdout + else: + f = open(rcfile,'w') + for line in self.Lines: + line = line.rstrip() + name, value, comment = _parseLine(line,self.delim) + if name: + if self.Rc[name]['flag']: + if comment: + comment = '#' + comment + else: + comment = '' + value = self.Rc[name]['value'] + print >>f, name + self.delim+' ' + str(value) + comment # this line has been edited + else: + print >>f, line + else: + print >>f, line + f.close() + + def upd(self,dict): + pass + + def interp(self,str,outFile=None,**kws): + """ + Use the resource values for $-substitution (a.k.a. + interpolation.) When *outFile* is specified *str* is assumed + to be the name of the input template file. Otherwise, + *str* is a simple string template to be interpolated. + """ + if outFile is None: + return self.interpStr(str,**kws) + else: + self.interpFile(str,outFile,**kws) + + def interpFile(self,template,outFile,**kws): + """ + Use the resource values for $-substitution in the + input template file *Template* + """ + Tmpl = open(template).readlines() + Text = [] + for tmpl in Tmpl: + Text.append(self.interpStr(tmpl,**kws)) + open(outFile,"w").writelines(Text) + + def interpStr(self,template,strict=False): + """ + Replace occurences of resource variables in the + input string *StrTemplate*. For example, if + StrTemplate = "This is $thing" + $thing will be replaced with the value of the + resource *thing*. When *strict* is True, an + exeption will be raised if any $-token is left + unresolved. + """ + dict = {} + for name in self.Rc: + dict[name] = self.Rc[name]['value'] + if strict: + return string.Template(template).substitute(dict) + else: + return string.Template(template).safe_substitute(dict) + + def regex(self,pattern,ignoreCase=True): + """ + Return a dictionary with those resources matching the + regular expression *pattern*. For example. + cf.regex('RESTART_FILE').values() + return a list of all restart files. + """ + if ignoreCase is True: + p = re.compile(pattern,re.IGNORECASE) + else: + p = re.compile(pattern) + dict = {} + for name in self.Rc: + if p.search(name) is not None: + dict[name] = self.Rc[name]['value'] + return dict + + def setenv(self,Only=None): + """ + Use resources to set environment variables. Option, + one can provide a list of strings (*Only*) with those + resources to be turned into environment variables. + """ + for name in self.Rc: + if Only is None: + os.environ[name] = self.Rc[name]['value'] + elif name in Only: + os.environ[name] = self.Rc[name]['value'] + + def keys(self): + """ + Return list of resource names. + """ + return self.Rc.keys() + + def values(self): + """ + Return list of resource names. + """ + vals = [] + for name in self.Rc: + vals.append(self.Rc[name]['value']) + return vals + + def strTemplate(self,name,expid=None,nymd=None,nhms=None, + yy=None,mm=None,dd=None,h=None,m=None,s=None,dtime=None): + """ + Expand GrADS style templates in resource *name*. See + static method strTemplate() for additional information + on the date/time input parameters. + """ + return strTemplate(self(name),expid,nymd,nhms,yy,mm,dd,h,m,s,dtime) + +# Static Methods +# -------------- + +def _parseLine(line,delim): + name, value, comment = (None,None,None) + if line: + all = line.split('#',1) + rc = all[0] + if len(all)>1: + comment = all[1] + if rc: + rcs = rc.split(delim,1) # resource name and value + if len(rcs) > 1: + name = rcs[0].strip() + value = rcs[1].strip() + return name, value, comment + +def strTemplate(templ,expid=None,nymd=None,nhms=None, + yy=None,mm=None,dd=None,h=None,m=None,s=None, + dtime=None): + """ + Expands GrADS template in string *templ*. On input, + + expid --- experiment id, expands %s + yy --- year, expands %y4 and %y2 + mm --- month, expands %m2 or %m3 + dd --- day, expands %d2 + h --- hour, expands %h2 + m --- minute, expands %n2 + s --- minute, expands %S2 (notice capital "S") + + nymd --- same as yy*10000 + mm*100 + dd + nhms --- same as h *10000 + h*100 + s + + dtime --- python datetime + + Unlike GrADS, notice that seconds are expanded using the %S2 token. + Input date/time can be either strings or integers. + + Examples: + + >>> templ = "%s.aer_f.eta.%m3%y2.%y4%m2%d2_%h2:%n2:%S2z.nc" + >>> print strTemplate(templ,expid="e0054A",yy=2008,mm=6,dd=30,h=1,m=30,s=47) + e0054A.aer_f.eta.jun08.20080630_01:30:47z.nc + >>> print strTemplate(templ,expid="e0054A",nymd=20080630,nhms=13000) + e0054A.aer_f.eta.jun08.20080630_01:30:00z.nc + + """ + + MMM = ( 'jan', 'feb', 'mar', 'apr', 'may', 'jun', + 'jul', 'aug', 'sep', 'oct', 'nov', 'dec' ) + + str_ = templ[:] + + if dtime is not None: + yy = dtime.year + mm = dtime.month + dd = dtime.day + h = dtime.hour + m = dtime.minute + s = dtime.second + + if nymd is not None: + nymd = int(nymd) + yy = nymd/10000 + mm = (nymd - yy*10000)/100 + dd = nymd - (10000*yy + 100*mm ) + + if nhms is not None: + nhms = int(nhms) + h = nhms/10000 + m = (nhms - h * 10000)/100 + s = nhms - (10000*h + 100*m) + + if expid is not None: + str_ = str_.replace('%s',expid) + if yy is not None: + y2 = yy%100 + str_ = str_.replace('%y4',str(yy)) + str_ = str_.replace('%y2',"%02d"%y2) + if mm is not None: + mm = int(mm) + mmm = MMM[mm-1] + str_ = str_.replace('%m2',"%02d"%mm) + str_ = str_.replace('%m3',mmm) + if dd is not None: + str_ = str_.replace('%d2',"%02d"%int(dd)) + if h is not None: + str_ = str_.replace('%h2',"%02d"%int(h)) + if m is not None: + str_ = str_.replace('%n2',"%02d"%int(m)) + if s is not None: + str_ = str_.replace('%S2',"%02d"%int(s)) + + return str_ + +#................................................................ + +# Testing +# ------- + +def _ut_strTemplate(): + + + + templ = "%s.aer_f.eta.%m3%y2.%y4%m2%d2_%h2:%n2:%S2z.nc" + + expid = "e0054A" + yy = "2008" + mm = "10" + dd = "30" + + h = "1" + m = "30" + s = "47" + + dtime = datetime(2008,10,30,1,30,47) + + nymd = int(yy) * 10000 + int(mm)*100 + int(dd) + nhms = int(h) * 10000 + int(m) * 100 + int(s) + + print "Template: "+templ + print strTemplate(templ) + print strTemplate(templ,expid=expid) + print strTemplate(templ,expid=expid,yy=2008) + print strTemplate(templ,expid=expid,yy=2008,mm=mm) + print strTemplate(templ,expid=expid,yy=2008,mm=mm,dd=dd) + print strTemplate(templ,expid=expid,yy=2008,mm=mm,dd=dd,h=h) + print strTemplate(templ,expid=expid,yy=2008,mm=mm,dd=dd,h=h,m=m,s=s) + print strTemplate(templ,expid=expid,nymd=nymd) + print strTemplate(templ,expid=expid,nymd=nymd,nhms=nhms) + print strTemplate(templ,expid=expid,dtime=dtime) + +if __name__ == "__main__": + cf = Config('test.rc', delim=' = ') + +# _ut_strTemplate() + diff --git a/Python/MAPL/constants.py b/Python/MAPL/constants.py new file mode 100644 index 000000000000..54bc5fe35c8d --- /dev/null +++ b/Python/MAPL/constants.py @@ -0,0 +1,33 @@ +""" +Python version of MAPL Constants. +""" + +MAPL_PI = 3.14159265358979323846 +MAPL_GRAV = 9.80 # m^2/s +MAPL_RADIUS = 6376.0E3 # m +MAPL_OMEGA = 2.0*MAPL_PI/86164.0 # 1/s +MAPL_ALHL = 2.4665E6 # J/kg @15C +MAPL_ALHF = 3.3370E5 # J/kg +MAPL_ALHS = MAPL_ALHL+MAPL_ALHF # J/kg +MAPL_STFBOL = 5.6734E-8 # W/(m^2 K^4) +MAPL_AIRMW = 28.97 # kg/Kmole +MAPL_H2OMW = 18.01 # kg/Kmole +MAPL_O3MW = 47.9982 # kg/Kmole +MAPL_RUNIV = 8314.3 # J/(Kmole K) +MAPL_KAPPA = 2.0/7.0 # -- +MAPL_RVAP = MAPL_RUNIV/MAPL_H2OMW # J/(kg K) +MAPL_RGAS = MAPL_RUNIV/MAPL_AIRMW # J/(kg K) +MAPL_CP = MAPL_RGAS/MAPL_KAPPA # J/(kg K) +MAPL_P00 = 100000.0 # Pa +MAPL_CAPICE = 2000. # J/(K kg) +MAPL_CAPWTR = 4218. # J/(K kg) +MAPL_RHOWTR = 1000. # kg/m^3 +MAPL_NUAIR = 1.533E-5 # m^2/S (@ 18C) +MAPL_TICE = 273.16 # K +MAPL_SRFPRS = 98470 # Pa +MAPL_KARMAN = 0.40 # -- +MAPL_USMIN = 1.00 # m/s +MAPL_VIREPS = MAPL_AIRMW/MAPL_H2OMW-1.0 # -- +MAPL_AVOGAD = 6.023E26 # 1/kmol + +MAPL_UNDEF = 1.0e15 diff --git a/Python/MAPL/eta.py b/Python/MAPL/eta.py new file mode 100644 index 000000000000..c39b07ffb6f0 --- /dev/null +++ b/Python/MAPL/eta.py @@ -0,0 +1,420 @@ +""" +Python implementation of set_eta module under GMA_Shared/GMAO_hermes. + +""" + +from numpy import ones + +ak = {} +bk = {} + +# NCAR settings +# ------------- + +ak['18'] = [ 291.70, 792.92, 2155.39, 4918.34, 8314.25, + 7993.08, 7577.38, 7057.52, 6429.63, 5698.38, + 4879.13, 3998.95, 3096.31, 2219.02, 1420.39, + 754.13, 268.38, 0.0000, 0.0000 ] + +bk['18'] = [ 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, + 0.0380541, 0.0873088, 0.1489307, 0.2232996, + 0.3099406, 0.4070096, 0.5112977, 0.6182465, + 0.7221927, 0.8168173, 0.8957590, 0.9533137, + 0.9851122, 1.0 ] + +ak['26'] = [ 219.4067, 489.5209, 988.2418, 1805.201, + 2983.724, 4462.334, 6160.587, 7851.243, + 7731.271, 7590.131, 7424.086, 7228.744, + 6998.933, 6728.574, 6410.509, 6036.322, + 5596.111, 5078.225, 4468.96, 3752.191, + 2908.949, 2084.739, 1334.443, 708.499, + 252.136, 0., 0. ] + +bk['26'] = [ 0., 0., 0., 0., + 0., 0., 0., 0., + 0.01505309, 0.03276228, 0.05359622, 0.07810627, + 0.1069411, 0.14086370, 0.180772, 0.227722, + 0.2829562, 0.3479364, 0.4243822, 0.5143168, + 0.6201202, 0.7235355, 0.8176768, 0.8962153, + 0.9534761, 0.9851122, 1. ] + +ak['30'] = [ 225.523952394724, 503.169186413288, 1015.79474285245, + 1855.53170740604, 3066.91229343414, 4586.74766123295, + 6332.34828710556, 8070.14182209969, 9494.10423636436, + 11169.321089983, 13140.1270627975, 15458.6806893349, + 18186.3352656364, 17459.799349308, 16605.0657629967, + 15599.5160341263, 14416.541159153, 13024.8308181763, + 11387.5567913055, 9461.38575673103, 7534.44507718086, + 5765.89405536652, 4273.46378564835, 3164.26791250706, + 2522.12174236774, 1919.67375576496, 1361.80268600583, + 853.108894079924, 397.881818935275, 0., + 0. ] + +bk['30'] = [ 0., 0., + 0., 0., 0., + 0., 0., 0., + 0., 0., 0., + 0., 0., 0.03935482725501, + 0.085653759539127, 0.140122056007385, 0.20420117676258, + 0.279586911201477, 0.368274360895157, 0.47261056303978, + 0.576988518238068, 0.672786951065063, 0.75362843275070, + 0.813710987567902, 0.848494648933411, 0.88112789392471, + 0.911346435546875, 0.938901245594025, 0.96355980634689, + 0.985112190246582, 1. ] + +# NASA DAO settings +# ----------------- + +ak['32'] = [0.00000, 106.00000, 224.00000, + 411.00000, 685.00000, 1065.00000, + 1565.00000, 2179.80000, 2900.00000, + 3680.00000, 4550.00000, 5515.00000, + 6607.00000, 7844.00000, 9236.56616, + 10866.34280, 12783.70000, 15039.29900, + 17693.00000, 20815.20900, 24487.49020, + 28808.28710, 32368.63870, 33739.96480, + 32958.54300, 30003.29880, 24930.12700, + 18568.89060, 12249.20510, 6636.21191, + 2391.51416, 0.00000, 0.00000 ] + +bk['32'] = [0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.01523, 0.06132, + 0.13948, 0.25181, 0.39770, + 0.55869, 0.70853, 0.83693, + 0.93208, 0.98511, 1.00000 ] + +ak['48'] = [40.00000, 100.00000, 200.00000, + 350.00000, 550.00000, 800.00000, + 1085.00000, 1390.00000, 1720.00000, + 2080.00000, 2470.00000, 2895.00000, + 3365.00000, 3890.00000, 4475.00000, + 5120.00000, 5830.00000, 6608.00000, + 7461.00000, 8395.00000, 9424.46289, + 10574.46900, 11864.80330, 13312.58850, + 14937.03770, 16759.70760, 18804.78670, + 21099.41250, 23674.03720, 26562.82650, + 29804.11680, 32627.31601, 34245.89759, + 34722.29104, 34155.20062, 32636.50533, + 30241.08406, 27101.45052, 23362.20912, + 19317.04955, 15446.17194, 12197.45091, + 9496.39912, 7205.66920, 5144.64339, + 3240.79521, 1518.62245, 0.00000, + 0.00000 ] + +bk['48'] = [0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00813, 0.03224, + 0.07128, 0.12445, 0.19063, + 0.26929, 0.35799, 0.45438, + 0.55263, 0.64304, 0.71703, + 0.77754, 0.82827, 0.87352, + 0.91502, 0.95235, 0.98511, + 1.00000 ] + +ak['55'] = [ 1.00000, 2.00000, 3.27000, + 4.75850, 6.60000, 8.93450, + 11.97030, 15.94950, 21.13490, + 27.85260, 36.50410, 47.58060, + 61.67790, 79.51340, 101.94420, + 130.05080, 165.07920, 208.49720, + 262.02120, 327.64330, 407.65670, + 504.68050, 621.68000, 761.98390, + 929.29430, 1127.68880, 1364.33920, + 1645.70720, 1979.15540, 2373.03610, + 2836.78160, 3380.99550, 4017.54170, + 4764.39320, 5638.79380, 6660.33770, + 7851.22980, 9236.56610, 10866.34270, + 12783.70000, 15039.30000, 17693.00000, + 20119.20876, 21686.49129, 22436.28749, + 22388.46844, 21541.75227, 19873.78342, + 17340.31831, 13874.44006, 10167.16551, + 6609.84274, 3546.59643, 1270.49390, + 0.00000, 0.00000 ] + +bk['55'] = [0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00696, 0.02801, 0.06372, + 0.11503, 0.18330, 0.27033, + 0.37844, 0.51046, 0.64271, + 0.76492, 0.86783, 0.94329, + 0.98511, 1.00000 ] + + +# NCEP's 64 sigma layers +# ---------------------- + +ak['64'] = [1.00000, 3.90000, 8.70000, + 15.42000, 24.00000, 34.50000, + 47.00000, 61.50000, 78.60000, + 99.13500, 124.12789, 154.63770, + 191.69700, 236.49300, 290.38000, + 354.91000, 431.82303, 523.09300, + 630.92800, 757.79000, 906.45000, + 1079.85000, 1281.00000, 1515.00000, + 1788.00000, 2105.00000, 2470.00000, + 2889.00000, 3362.00000, 3890.00000, + 4475.00000, 5120.00000, 5830.00000, + 6608.00000, 7461.00000, 8395.00000, + 9424.46289, 10574.46880, 11864.80270, + 13312.58890, 14937.03710, 16759.70700, + 18804.78710, 21099.41210, 23674.03710, + 26562.82810, 29804.11720, 32627.31640, + 34245.89840, 34722.28910, 34155.19920, + 32636.50390, 30241.08200, 27101.44920, + 23362.20700, 19317.05270, 15446.17090, + 12197.45210, 9496.39941, 7205.66992, + 5144.64307, 3240.79346, 1518.62134, + 0.00000, 0.00000 ] + +bk['64'] = [0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00813, + 0.03224, 0.07128, 0.12445, + 0.19063, 0.26929, 0.35799, + 0.45438, 0.55263, 0.64304, + 0.71703, 0.77754, 0.82827, + 0.87352, 0.91502, 0.95235, + 0.98511, 1.00000 ] + + +ak['72'] = [ 1.0000000, 2.0000002, 3.2700005, 4.7585009, 6.6000011, + 8.9345014, 11.970302, 15.949503, 21.134903, 27.852606, + 36.504108, 47.580610, 61.677911, 79.513413, 101.94402, + 130.05102, 165.07903, 208.49704, 262.02105, 327.64307, + 407.65710, 504.68010, 621.68012, 761.98417, 929.29420, + 1127.6902, 1364.3402, 1645.7103, 1979.1604, 2373.0405, + 2836.7806, 3381.0007, 4017.5409, 4764.3911, 5638.7912, + 6660.3412, 7851.2316, 9236.5722, 10866.302, 12783.703, + 15039.303, 17693.003, 20119.201, 21686.501, 22436.301, + 22389.800, 21877.598, 21214.998, 20325.898, 19309.696, + 18161.897, 16960.896, 15625.996, 14290.995, 12869.594, + 11895.862, 10918.171, 9936.5219, 8909.9925, 7883.4220, + 7062.1982, 6436.2637, 5805.3211, 5169.6110, 4533.9010, + 3898.2009, 3257.0809, 2609.2006, 1961.3106, 1313.4804, + 659.37527, 4.8048257, 0.0000000 ] + + +bk['72'] = [0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 0.0000000, 0.0000000, 0.0000000, 0.0000000, + 0.0000000, 8.1754130e-09, 0.0069600246, 0.028010041, 0.063720063, + 0.11360208, 0.15622409, 0.20035011, 0.24674112, 0.29440312, + 0.34338113, 0.39289115, 0.44374018, 0.49459020, 0.54630418, + 0.58104151, 0.61581843, 0.65063492, 0.68589990, 0.72116594, + 0.74937819, 0.77063753, 0.79194696, 0.81330397, 0.83466097, + 0.85601798, 0.87742898, 0.89890800, 0.92038701, 0.94186501, + 0.96340602, 0.98495195, 1.0000000 ] + + +# ECMWF Nature +# ------------ +ak['91'] = [ 0.000000000000, 2.000040054321, 3.980832099915, 7.387186050415, + 12.908319473267, 21.413604736328, 33.952865600586, 51.746597290039, + 76.167663574219, 108.715560913086, 150.986022949219, 204.637451171875, + 271.356445312500, 352.824462890625, 450.685791015625, 566.519287109375, + 701.813232421875, 857.945800781250, + 1036.166503906250, 1237.585449218750, 1463.163818359375, 1713.709716796875, + 1989.874511718750, 2292.155517578125, 2620.898437500000, 2976.302246093750, + 3358.425781250000, 3767.196044921875, 4202.417968750000, 4663.777343750000, + 5150.859375000000, 5663.156250000000, 6199.839843750000, 6759.726562500000, + 7341.468750000000, 7942.925781250000, 8564.625000000000, 9208.304687500000, + 9873.562500000000, 10558.882812500000, 11262.484375000000, 11982.660156250000, + 12713.898437500000, 13453.226562500000, 14192.011718750000, 14922.687500000000, + 15638.054687500000, 16329.562500000000, 16990.625000000000, 17613.281250000000, + 18191.031250000000, 18716.968750000000, 19184.546875000000, 19587.515625000000, + 19919.796875000000, 20175.394531250000, 20348.917968750000, 20434.156250000000, + 20426.218750000000, 20319.011718750000, 20107.031250000000, 19785.359375000000, + 19348.777343750000, 18798.824218750000, 18141.296875000000, 17385.593750000000, + 16544.585937500000, 15633.566406250000, 14665.644531250000, 13653.218750000000, + 12608.382812500000, 11543.167968750000, 10471.312500000000, 9405.222656250000, + 8356.253906250000, 7335.164062500000, 6353.921875000000, 5422.800781250000, + 4550.214843750000, 3743.464355468750, 3010.146972656250, 2356.202636718750, + 1784.854492187500, 1297.656250000000, 895.193603515625, 576.314208984375, + 336.772460937500, 162.043426513672, 54.208343505859 , 6.575628280640, + 0.003160000080, 0.000000000000] + +bk['91'] = [ 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000000000, 0.000000000000, + 0.000000000000, 0.000000000000, 0.000000272400, 0.000013911600, + 0.000054667194, 0.000131364097, 0.000278884778, 0.000548384152, + 0.001000134507, 0.001701075351, 0.002764719306, 0.004267048091, + 0.006322167814, 0.009034991264, 0.012508261949, 0.016859579831, + 0.022188644856, 0.028610348701, 0.036226909608, 0.045146133751, + 0.055474229157, 0.067316174507, 0.080777287483, 0.095964074135, + 0.112978994846, 0.131934821606, 0.152933537960, 0.176091074944, + 0.201520144939, 0.229314863682, 0.259554445744, 0.291993439198, + 0.326329410076, 0.362202584743, 0.399204790592, 0.436906337738, + 0.475016415119, 0.513279736042, 0.551458477974, 0.589317142963, + 0.626558899879, 0.662933588028, 0.698223590851, 0.732223808765, + 0.764679491520, 0.795384764671, 0.824185431004, 0.850950419903, + 0.875518381596, 0.897767245770, 0.917650938034, 0.935157060623, + 0.950273811817, 0.963007092476, 0.973466038704, 0.982238113880, + 0.989152967930, 0.994204163551, 0.997630119324, 1.000000000000] + + +ak['96'] = [ 1.00000, 2.32782, 3.34990, + 4.49484, 5.62336, 6.93048, + 8.41428, 10.06365, 11.97630, + 14.18138, 16.70870, 19.58824, + 22.84950, 26.52080, 30.62845, + 35.19588, 40.24273, 45.78375, + 51.82793, 58.43583, 65.62319, + 73.40038, 81.77154, 90.73373, + 100.27628, 110.82243, 122.47773, + 135.35883, 149.59464, 165.32764, + 182.71530, 201.93164, 223.16899, + 246.63988, 272.57922, 301.24661, + 332.92902, 367.94348, 406.64044, + 449.40720, 496.67181, 548.90723, + 606.63629, 670.43683, 740.94727, + 818.87329, 904.99493, 1000.17395, + 1105.36304, 1221.61499, 1350.09326, + 1492.08362, 1649.00745, 1822.43469, + 2014.10168, 2225.92627, 2460.02905, + 2718.75195, 3004.68530, 3320.69092, + 3669.93066, 4055.90015, 4482.46240, + 4953.88672, 5474.89111, 6050.68994, + 6687.04492, 7390.32715, 8167.57373, + 9026.56445, 9975.89648, 11025.06934, + 12184.58398, 13466.04785, 14882.28320, + 16447.46289, 18177.25781, 20088.97461, + 21886.89453, 23274.16602, 24264.66602, + 24868.31641, 25091.15430, 24935.41016, + 24399.52148, 23478.13281, 22162.01758, + 20438.00586, 18288.83984, 15693.01172, + 12624.54199, 9584.35352, 6736.55713, + 4231.34326, 2199.57910, 747.11890, + 0.00000 ] + +bk['96'] = [0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00000, 0.00000, 0.00000, + 0.00315, 0.01263, 0.02853, + 0.05101, 0.08030, 0.11669, + 0.16055, 0.21231, 0.27249, + 0.34169, 0.42062, 0.51005, + 0.61088, 0.70748, 0.79593, + 0.87253, 0.93400, 0.97764, + 1.00000 ] + +def getEdge(km): + """Return tuple with edge values of (ak,bk) for the input number of + vertical layers *km*. Notice that the ak's are in units of Pascal (Pa). """ + ae = ones(km+1) + be = ones(km+1) + ae[:] = ak[str(km)] + be[:] = bk[str(km)] + return (ae,be) + +def getMid(km): + """Return tuple with mid-layer values of (ak,bk) for the input number of + vertical layers *km*. Notice that the ak's are in units of Pascal (Pa). """ + ae, be = (ak[str(km)], bk[str(km)]) + am = ones(km) + bm = ones(km) + for k in range(km): + am[k] = (ae[k+1] + ae[k]) / 2. + bm[k] = (be[k+1] + be[k]) / 2. + return (am,bm) + +def getDelta(km): + """Return tuple with delta values of (ak,bk) for the input number of + vertical layers *km*. Notice that the ak's are in units of Pascal (Pa). """ + ae, be = (ak[str(km)], bk[str(km)]) + dak = ones(km) + dbk = ones(km) + for k in range(km): + dak[k] = ae[k+1] - ae[k] + dbk[k] = be[k+1] - be[k] + return (dak,dbk) + +def getPe(km,p_ref=100000.): + """Return pressure at edges given a reference pressure.""" + ae, be = getEdge(km) + return (ae + p_ref * be) + +def getPm(km,p_ref=100000.): + """Return pressure at mid-layer given a reference pressure.""" + am, bm = getMid(km) + return (am + p_ref * bm) + +def getDelp(km,p_ref=100000.): + """Return pressure thickness at mid-layer given a reference pressure.""" + dak, dbk = getDelta(km) + return (dak + p_ref * dbk) + + + diff --git a/Python/MAPL/exp.py b/Python/MAPL/exp.py new file mode 100644 index 000000000000..70d7119c0a59 --- /dev/null +++ b/Python/MAPL/exp.py @@ -0,0 +1,112 @@ +""" +This package implements the Experiment class. +""" + +import os + +class Exp(object): + + def __init__(self,ConfigFiles=None): + + if ConfigFiles is None: + here = _whereami() + Configfiles = [ here + 'Experiment.rc', + here + 'Grids.rc', + here + 'Chem_Registry.rc' + ] + + self.cf = Config(ConfigFiles); + + self.EsmaDir = self.cf.EsmaDir # Location of system binaries + + self.SysID = self.cf.SysID # e.g., "GEOSagcm" + self.ExpID = self.cf.ExpID # e.g., "a0202" + self.ExpDescr = self.cf.ExpDescr + + self.ExpHomeDir = self.cf.ExpHomeDir + self.ExpExecDir = self.cf.ExpExecDir + self.ExpHoldDir = self.cf.ExpHoldDir + self.ExpArchDir = self.cf.ExpArchDir + + self.ExpBegTime = cf.ExpBegTime + self.ExpEndTime = cf.ExpEndTime + + def __del__(self): + self.submit() # resubmit itsef + + def submit(self): + raise NotImplementedError, "Not implemented yet" + + +# -------------- +# Static Methods +# -------------- + +def setup(inConfigFiles=None): + """ + In the very beginning, setup the environment for + running the experiment. It interacts with the user + to setup all the necessary experiment directories + and resource files. + """ + +# Default (input) Config files +# ---------------------------- + if inConfigFiles is None: + etc = _whereami() + '../etc' + inConfigfiles = [ here + 'Experiment.irc', + here + 'Grids.irc', + here + 'Chem_Registry.irc', + here + 'History.irc' + ] + +# Derive Config file names by replacing ".irc" extensions with ".rc" +# ------------------------------------------------------------------ + cmd = '$ESMADIR/bin/red_ma.pl' + ConfigFiles = [] + for irc in inConfigFiles: + cmd = cmd + ' ' + irc + ConfigFiles.append(irc.replace('.irc','.rc')) + +# Get user input by lauching Red MAPL GUI +# --------------------------------------- + tmpdir = "/tmp/red_mapl.%s-%d"%(os.getenv('USER'),os.getpid()) + os.mkdir(tmpdir) + os.chdir(tmpdir) + if os.system(cmd): + raise IOerror, "red_ma.pl did not complete successfully" + +# Resources as specified by user +# ------------------------------ + cf = Config(ConfigFiles) + +# Setup directory tree +# -------------------- + for dir in cf.regex('Dir$').values(): + os.mkdir(dir) + +# Populate Resources +# ------------------ + cf.save(cf('ExpRsrcDir')+'/Master.rc') + os.system('/bin/cp -pr $ESMADIR/$ARCH/etc/*.rc ' + + cf('ExpRsrcDir') ) + +# All done +# -------- + os.system('/bin/rm -rf ' + tmpdir) + +def tearDown(self): + """ + Once an experiment is completed, run this for all + necessary cleanup. + """ + pass # can't think of anything useful yet + +#......................................................................................... + +if __name__ == "__main__": + + e = Experiment() + e.submitt() + + diff --git a/Python/MAPL/filelock.py b/Python/MAPL/filelock.py new file mode 100644 index 000000000000..ec754800c712 --- /dev/null +++ b/Python/MAPL/filelock.py @@ -0,0 +1,77 @@ +import os +import time +import errno + +class FileLockException(Exception): + pass + +class FileLock(object): + """ A file locking mechanism that has context-manager support so + you can use it in a with statement. This should be relatively cross + compatible as it doesn't rely on msvcrt or fcntl for the locking. + """ + + def __init__(self, file_name, timeout=10, delay=.05): + """ Prepare the file locker. Specify the file to lock and optionally + the maximum timeout and the delay between each attempt to lock. + """ + self.is_locked = False + self.lockfile = os.path.join(os.getcwd(), "%s.lock" % file_name) + self.file_name = file_name + self.timeout = timeout + self.delay = delay + + + def acquire(self): + """ Acquire the lock, if possible. If the lock is in use, it check again + every `wait` seconds. It does this until it either gets the lock or + exceeds `timeout` number of seconds, in which case it throws + an exception. + """ + start_time = time.time() + while True: + try: + self.fd = os.open(self.lockfile, os.O_CREAT|os.O_EXCL|os.O_RDWR) + break; + except OSError: + if OSError.errno != errno.EEXIST: + raise + if (time.time() - start_time) >= self.timeout: + raise FileLockException("Timeout occured.") + time.sleep(self.delay) + self.is_locked = True + + + def release(self): + """ Get rid of the lock by deleting the lockfile. + When working in a `with` statement, this gets automatically + called at the end. + """ + if self.is_locked: + os.close(self.fd) + os.unlink(self.lockfile) + self.is_locked = False + + + def __enter__(self): + """ Activated when used in the with statement. + Should automatically acquire a lock to be used in the with block. + """ + if not self.is_locked: + self.acquire() + return self + + + def __exit__(self, type, value, traceback): + """ Activated at the end of the with statement. + It automatically releases the lock if it isn't locked. + """ + if self.is_locked: + self.release() + + + def __del__(self): + """ Make sure that the FileLock instance doesn't leave a lockfile + lying around. + """ + self.release() diff --git a/Python/MAPL/history.py b/Python/MAPL/history.py new file mode 100644 index 000000000000..476da2173652 --- /dev/null +++ b/Python/MAPL/history.py @@ -0,0 +1,59 @@ +""" +A special class for handling history resources. +""" + +from config import * + +class History(Config): + + def collections(self): + """ + Returns a list of active collections. + """ + p = re.compile('^[ ]*::') + on = False + for line in self.Lines: + tok = line.lstrip() + if tok[0:11] == 'COLLECTIONS': + first = self.get('COLLECTIONS') + if first != '': + colls = [ first.replace("'",""), ] + else: + colls = [] + on = True + elif on is True: + if tok[0:2] == '::': + break + elif tok[0:1] != '#': + coll = tok.split()[0] + colls.append(coll.replace("'","")) + return colls + + def arc(self,outFile): + """ + Create a PESTO resource file (.arc) based on the + *.temkplate resources. + """ + dict = self.regex('template$') + Tmpl = [str.replace("'","").replace(",","") for str in dict.values()] + Coll = [ str.split('.')[0].replace(",","") for str in dict.keys() ] + Arch = [str.replace("'","").replace(",","") \ + for str in self.regex('archive$').values()] + + if len(Tmpl) != len(Arch): + raise IOError,\ + "There are %d template resources but only %d archive resources."\ + %(len(Tmpl),len(Arch)) + + header = '# PESTO resource for History Collections ' + \ + '(automatically generated - do not edit)' + Text = [header,] + c = 0 + for tmpl in Tmpl: + coll = Coll[c] + path = Arch[c].replace('%c',coll) + line = '$PESTOROOT%s/' + path + '/%s.' + coll + \ + '.' + tmpl + '\n' + Text.append(line) + c = c + 1 + open(outFile,"w").writelines(Text) diff --git a/Python/MAPL/job.py b/Python/MAPL/job.py new file mode 100644 index 000000000000..abfd3ce5d571 --- /dev/null +++ b/Python/MAPL/job.py @@ -0,0 +1,92 @@ +""" +This package implements the functionality of a single Job. Methods +specifics of an applcation are defined as "abstract" --- that is, to be +defined by each specific Application. + +Design remarks: + +1. A Job should not have any knowledge of the specific Operating System + (OS) and Queueing System (QS). If this knowledge becomes essential + it should be abstracted out and implemented in the Experiment class. + +""" + +import Abstract +from exp import Exp + +class Job(Exp): + + def __init__(self,ConfigFile): + """Initialize a Job.""" + +# Initialize Experiment specific stuff in base class +# -------------------------------------------------- + Exp.__init__(self,ConfigFile) + +# Job specific parameters (will raise exception if not present) +# ------------------------------------------------------------- + self.nSegs = self.cf.nSegs + self.recyclables = self.cf.recyclables # File list + self.JobDelTime = self.cf.DelTime + +# Bring over resource files +# ------------------------- + self.getResources() + +# Bring over recyclables to runing ExpExecDir +# ---------------------------------- -------- + self.getRecyclables() + + def __call__(self): + """ + Carries out a single Job by running several segments of the + Application. + """ + +# Per-job Application setup +# ------------------------- + self.signin() + +# Run application for each segment +# -------------------------------- + for n in range(self.nSegs): + self.execute() + +# Per-job Application clean-up +# ---------------------------- + self.signout() + + def __del__(self): + +# Save recyclables to ExpHomeDir for next Job +# ------------------------------------------- + self.putRecyclables() + +# Finalize experiment specific stuff in base class; +# this will resubmit the job if necessary +# ------------------------------------------------ + Experiment.__del__(self) + +# ----------------- +# Recycling Methods +# ----------------- + + def getResources(self): + raise NotImplementedError, "Not implemented yet" + + def getRecyclables(self): + raise NotImplementedError, "Not implemented yet" + + def putRecyclables(self): + raise NotImplementedError, "Not implemented yet" + + +# ---------------- +# Abstract Methods +# ---------------- + + signin = Abstract.Method('signin') + execute = Abstract.Method('execute') + signout = Abstract.Method('signout') + + diff --git a/Python/MAPL/run.py b/Python/MAPL/run.py new file mode 100644 index 000000000000..4a6837097230 --- /dev/null +++ b/Python/MAPL/run.py @@ -0,0 +1,84 @@ +""" +This package implements the running of a segment: it runs a MAPL +application for a prescribed period of time (or the end of the +experiment, whichever is sooner.) + +""" + +from job import Job + +class Run(Job): + + def __init__(self,ConfigFile,Children=[]): + +# Initialize Job specific stuff in base class +# ------------------------------------------- + Job.__init__(self,ConfigFile) + + self.Children = Children + +# ------------------- +# Per-segment Methods +# ------------------- + + def execute(self): + """Executes the Application for one segment.""" + self.initialize() + self.run() + self.finalize() + + def initialize(self): + self._initialize() + for child in self.Children: + child.initialize() + self.initialize_() + + def run(self): + self._run() + for child in self.Children: + child.run() + self.run_() + + def finalize(self): + self._finalize() + for child in self.Children: + child.finalize() + self.finalize_() + + +# ----------------- +# Per-job Methods +# ----------------- + + def signin(self): + self._signin() + for child in self.Children: + child.signin() + self.signin_() + + def signout(self): + self._signout() + for child in self.Children: + child.signout() + self.signout_() + + +# --------------------- +# No-op Default Methods +# --------------------- + +# No-op pre-child methods +# ----------------------- + def _initialize(self): pass + def _run(self): pass + def _finalize(self): pass + def _signin(self): pass + def _signout(self): pass + +# No-op post-child methods +# ------------------------ + def initialize_(self): pass + def run_(self): pass + def finalize_(self): pass + def signin_(self): pass + def signout_(self): pass diff --git a/Python/MAPL_SpecsCodeGenerator.py b/Python/MAPL_SpecsCodeGenerator.py deleted file mode 100644 index b60cc7a32d35..000000000000 --- a/Python/MAPL_SpecsCodeGenerator.py +++ /dev/null @@ -1,33 +0,0 @@ -import argparse -import DataSpec -import DataSpecsReader - -# command line arguments -parser = argparse.ArgumentParser(description='Generate import/export/internal specs for MAPL Gridded Component') -parser.add_argument('-i','--input', action='store') -parser.add_argument('--declare_specs', action='store', default='declare_specs.h') -parser.add_argument('--declare_local', action='store', default='declare_local.h') -parser.add_argument('--get_pointer', action='store', default='get_pointer.h') -args = parser.parse_args() - - -f_spec = open(args.declare_specs,'w') -f_local = open(args.declare_local,'w') -f_get_pointer = open(args.get_pointer,'w') - -specs = DataSpecsReader.read(args.input) -for category in ('IMPORT','EXPORT','INTERNAL'): - for item in specs[category].to_dict('records'): - spec = DataSpec.DataSpec(category.capitalize(), item) - f_spec.write(spec.emit_declare_spec()) - f_local.write(spec.emit_declare_local_variable()) - f_get_pointer.write(spec.emit_get_pointer()) - -f_spec.close() -f_local.close() -f_get_pointer.close() - - - - - diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index 9c96f051f7ee..36b8dd3de9de 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -63,7 +63,6 @@ function new_ExtData_DriverGridComp(root_set_services, configFileName, name) res type(MAPL_MetaComp_Wrapper) :: meta_comp_wrapper integer :: status, rc - character(len=ESMF_MAXSTR) :: Iam="new_ExtData_DriverGridComp" cap%root_set_services => root_set_services @@ -138,8 +137,6 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) integer :: HEARTBEAT_DT character(len=ESMF_MAXSTR) :: HIST_CF, ROOT_CF, EXTDATA_CF - character(len=ESMF_MAXSTR) :: Iam="initialize_gc" - type (MAPL_MetaComp), pointer :: MAPLOBJ procedure(), pointer :: root_set_services type(ExtData_DriverGridComp), pointer :: cap @@ -436,7 +433,6 @@ subroutine run_gc(gc, import, export, clock, rc) integer, intent(out) :: RC ! Error code: integer :: status - character(len=ESMF_MAXSTR) :: Iam="MAPL_GridCompCap::run()" _UNUSED_DUMMY(import) _UNUSED_DUMMY(export) @@ -456,7 +452,6 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) integer, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam = "CapGridComp_Finalize" type(ExtData_DriverGridComp), pointer :: cap type(MAPL_MetaComp), pointer :: MAPLOBJ @@ -502,7 +497,6 @@ subroutine set_services_gc(gc, rc) integer, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam="set_services" call ESMF_GridCompSetEntryPoint(gc, ESMF_METHOD_INITIALIZE, userRoutine = initialize_gc, rc = status) _VERIFY(status) @@ -518,7 +512,6 @@ end subroutine set_services_gc subroutine set_services(this, rc) class(ExtData_DriverGridComp), intent(inout) :: this integer, optional, intent(out) :: rc - character(*), parameter :: Iam = "set_services" integer :: status call ESMF_GridCompSetServices(this%gc, set_services_gc, rc = status) @@ -532,7 +525,6 @@ subroutine initialize(this, rc) integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam="Initialize" call ESMF_GridCompInitialize(this%gc, userRc = status) _VERIFY(status) @@ -546,7 +538,6 @@ subroutine run(this, rc) integer :: status integer :: userRc - character(len=ESMF_MAXSTR) :: Iam="run" call ESMF_GridCompRun(this%gc, userRC=userRC,rc=status) _ASSERT(userRC==ESMF_SUCCESS .and. STATUS==ESMF_SUCCESS,'run failed') @@ -560,7 +551,6 @@ subroutine finalize(this, rc) integer, optional, intent(out) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam="finalize" call ESMF_GridCompFinalize(this%gc, rc = status) _VERIFY(status) @@ -572,8 +562,6 @@ function get_am_i_root(this, rc) result (amiroot) class (ExtData_DriverGridComp) :: this integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR) :: Iam="get_am_i_root" - logical :: amiroot amiroot = this%amiroot @@ -608,7 +596,6 @@ subroutine run_MultipleTimes(gc, rc) integer, optional, intent(out) :: rc integer :: n, status - character(len=ESMF_MAXSTR) :: Iam="run_MultipleTimes" type(ExtData_DriverGridComp), pointer :: cap type (MAPL_MetaComp), pointer :: MAPLOBJ @@ -640,7 +627,6 @@ end subroutine run_MultipleTimes subroutine run_one_step(this, rc) class(ExtData_DriverGridComp), intent(inout) :: this integer, intent(out) :: rc - character(*), parameter :: Iam = "run_one_step" integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_H, AGCM_M, AGCM_S integer :: status @@ -716,7 +702,6 @@ subroutine MAPL_ClockInit ( cf, Clock, nsteps, rc) character(ESMF_MAXSTR) :: CALENDAR integer :: status integer :: datetime(2) - character(ESMF_MAXSTR) :: IAM="MAPL_ClockInit" type(ESMF_Calendar) :: cal type(ESMF_Time) :: CurrTime type(ESMF_TimeInterval) :: timeInterval, duration @@ -789,7 +774,6 @@ end subroutine MAPL_ClockInit subroutine parseTimes(this, rc) class(ExtData_DriverGridComp), intent(inout) :: this integer, intent(out), optional :: rc - character(*), parameter :: Iam = "parseTimes" integer :: comp_YY, comp_MM, comp_DD, comp_H, comp_M, comp_S,columnCount,lineCount,i,ctime(2) integer :: status @@ -817,7 +801,6 @@ subroutine advanceClockToTime(this, time,rc) class(ExtData_DriverGridComp), intent(inout) :: this type(ESMF_Time), intent(inout) :: time integer, intent(out), optional :: rc - character(*), parameter :: Iam = "advanceClockToTime" integer :: status type(ESMF_Time) :: currTime diff --git a/Tests/ExtDataDriverMod.F90 b/Tests/ExtDataDriverMod.F90 index e1687b34e87d..55880be6d9d6 100644 --- a/Tests/ExtDataDriverMod.F90 +++ b/Tests/ExtDataDriverMod.F90 @@ -46,6 +46,9 @@ function newExtDataDriver(name,set_services, unusable, cap_options) result(drive procedure() :: set_services class (KeywordEnforcer), optional, intent(in) :: unusable class ( MAPL_CapOptions), optional, intent(in) :: cap_options + + _UNUSED_DUMMY(unusable) + driver%name = name driver%set_services => set_services if (present(cap_options)) then @@ -65,7 +68,6 @@ subroutine run(this,RC) integer :: STATUS - character(len=ESMF_MAXSTR) :: Iam="ExtData_Driver" integer :: CommCap @@ -82,29 +84,29 @@ subroutine run(this,RC) CommCap = MPI_COMM_WORLD call this%initialize_io_clients_servers(commCap, rc = status); _VERIFY(status) - call ESMF_Initialize (vm=vm, logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=this%mapl_comm%esmf%comm, rc=status) - _VERIFY(STATUS) + select case(this%split_comm%get_name()) + case('model') + call ESMF_Initialize (vm=vm, logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=this%mapl_comm%esmf%comm, rc=status) + _VERIFY(STATUS) - config = ESMF_ConfigCreate(rc=status) - _VERIFY(status) - call ESMF_ConfigLoadFile ( config, 'CAP.rc', rc=STATUS ) - _VERIFY(status) - call ESMF_ConfigGetDim(config,lineCount,columnCount,label='CASES::',rc=status) - _VERIFY(status) - call ESMF_ConfigFindLabel(config,label='CASES::',rc=status) - _VERIFY(status) - do i=1,lineCount - call ESMF_ConfigNextLine(config,rc=status) + config = ESMF_ConfigCreate(rc=status) + _VERIFY(status) + call ESMF_ConfigLoadFile ( config, 'CAP.rc', rc=STATUS ) _VERIFY(status) - call ESMF_ConfigGetAttribute(config,ctemp,rc=status) + call ESMF_ConfigGetDim(config,lineCount,columnCount,label='CASES::',rc=status) + _VERIFY(status) + call ESMF_ConfigFindLabel(config,label='CASES::',rc=status) + _VERIFY(status) + do i=1,lineCount + call ESMF_ConfigNextLine(config,rc=status) + _VERIFY(status) + call ESMF_ConfigGetAttribute(config,ctemp,rc=status) + _VERIFY(status) + call cases%push_back(trim(ctemp)) + enddo + call ESMF_ConfigDestroy(config, rc=status) _VERIFY(status) - call cases%push_back(trim(ctemp)) - enddo - call ESMF_ConfigDestroy(config, rc=status) - _VERIFY(status) - select case(this%split_comm%get_name()) - case('model') iter = cases%begin() do while (iter /= cases%end()) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 9d6e22adae15..81e1213d649d 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -172,9 +172,10 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) integer :: status character(len=ESMF_MAXSTR) :: comp_name - real(REAL64) :: ptop, pint + !real(REAL64) :: ptop, pint !real(REAL64), allocatable :: ak(:),bk(:) - integer :: ls,im,jm,lm,nx,ny,nrows, ncolumn,i + integer :: im,jm,lm,nx,ny,nrows, ncolumn,i + !integer :: ls type(ESMF_Grid) :: grid type(ESMF_Time) :: currTime type(SyntheticFieldSupportWrapper) :: synthWrap @@ -279,7 +280,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type (ESMF_State), pointer :: GEX(:) character(len=ESMF_MAXSTR) :: Iam - integer :: STATUS,i + integer :: STATUS type(MAPL_MetaComp), pointer :: MAPL character(len=ESMF_MAXSTR) :: comp_name type(SyntheticFieldSupportWrapper) :: synthWrap @@ -518,9 +519,6 @@ subroutine FillState(inState,outState,time,Synth,rc) integer :: status character(len=*), parameter :: Iam=__FILE__//"::FillState" integer :: I - real, pointer :: IMptr3(:,:,:) => null() - real, pointer :: Exptr3(:,:,:) => null() - real, pointer :: IMptr2(:,:) => null() real, pointer :: Exptr2(:,:) => null() integer :: itemcount character(len=ESMF_MAXSTR), allocatable :: outNameList(:) diff --git a/cmake/mapl_acg.cmake b/cmake/mapl_acg.cmake new file mode 100644 index 000000000000..58ad5bcff7fb --- /dev/null +++ b/cmake/mapl_acg.cmake @@ -0,0 +1,66 @@ +################################################################################################ +# Automatically generate files from a file that provides specs +# for the states of a gridde component. +# +# Usage: +# +# mapl_acg (target specs_file ) +# +# Options: +# IMPORT_SPECS [file] include file for AddImportSpec() code (default _Import___.h) +# EXPORT_SPECS [file] include file for AddExportSpec() code (default _Export___.h) +# INTERNAL_SPECS [file] include file for AddInternalSpec() code (default _Internal___.h) +# GET_POINTERS [file] include file for GetPointer() code (default _GetPointer___.h) +# DECLARE_POINTERS [file] include file for declaring local pointers (default _DeclarePointer___.h) +# +################################################################################################ + + +function (mapl_acg target specs_file) + set (options) + set (oneValueArgs IMPORT_SPECS EXPORT_SPECS INTERNAL_SPECS GET_POINTERS DECLARE_POINTERS) + # This list must align with oneValueArgs above (for later ZIP_LISTS) + set (flags -i -x -p -g -d) + set (defaults Import Export Internal GetPointer DeclarePointer) + set (multiValueArgs) + cmake_parse_arguments (ARGS "${options}" "${oneValueArgs}" "${multiValueArgs}" ${ARGN}) + + string (REPLACE "_GridComp" "" component_name ${target}) + + if (ARGS_UNPARSED_ARGUMENTS) + ecbuild_error ("maple_acg() - unparsed arguments: ${ARGS_UNPARSED_ARGUMENTS}") + endif () + + set (generated) # empty unless + set (options "") + + + # Handle oneValueArgs with no value (Python provides default) + foreach (opt flag default IN ZIP_LISTS oneValueArgs flags defaults) + + if (ARGS_${opt}) + string (REPLACE "{component}" component_name fname ${ARGS_${opt}}) + list (APPEND generated ${fname}) + list (APPEND options ${flag} ${ARGS_${opt}}) + elseif (${opt} IN_LIST ARGS_KEYWORDS_MISSING_VALUES) + string (REPLACE "{component}" component_name fname ${default}) + list (APPEND generated ${fname}) + list (APPEND options ${flag}) + endif () + + endforeach () + + set(generator ${esma_etc}/MAPL/MAPL_GridCompSpecs_ACG.py) + + add_custom_command ( + OUTPUT ${generated} + COMMAND ${generator} ${CMAKE_CURRENT_SOURCE_DIR}/${specs_file} ${options} + MAIN_DEPENDENCY ${CMAKE_CURRENT_SOURCE_DIR}/${specs_file} + DEPENDS ${generator} ${specs_file} + WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} + COMMENT "Generating automatic code for ${specs_file}" + ) + add_custom_target (acg_phony_${target} DEPENDS ${generated}) + add_dependencies (${target} acg_phony_${target}) + +endfunction () diff --git a/components.yaml b/components.yaml new file mode 100644 index 000000000000..b35a1cfd01c4 --- /dev/null +++ b/components.yaml @@ -0,0 +1,16 @@ +env: + local: ./@env + remote: ../ESMA_env.git + tag: v2.1.0 + develop: master + +cmake: + local: ./@cmake + remote: ../ESMA_cmake.git + tag: v3.0.0 + develop: develop + +ecbuild: + local: ./@cmake/@ecbuild + remote: ../ecbuild.git + tag: geos/v1.0.1 diff --git a/include/unused_dummy.H b/include/unused_dummy.H new file mode 100644 index 000000000000..91337aca862c --- /dev/null +++ b/include/unused_dummy.H @@ -0,0 +1,13 @@ +! The following macro causes a variable to appear to be "used" +! according to the compiler. This is a kludge to avoid excessive +! warnings. In most cases, a better fix would be to modify the the +! procedure interface, but it is impractical in the short term. +! +! Note that the conditional is never satisfied and a reasonable +! compiler will optimize the line away. (Hopefully without +! reintroducing the warning!) + +#ifdef _UNUSED_DUMMY +# undef _UNUSED_DUMMY +#endif +#define _UNUSED_DUMMY(x) if (.false.) print*,shape(x)